TeX 1995 July

home *** CD-ROM | disk | FTP | other *** search

/ TeX 1995 July / TeX CD-ROM July 1995 (Disc 1)(Walnut Creek)(1995).ISO / web / clip / unix / clip.pas < prev next >

Wrap

Pascal/Delphi Source File | 1993-11-16 | 258.6 KB | 5,683 lines

(********** #File "CLIP_UNIX.PAS" (#Indent on, #Comment on) *******) (*********************************************************************) (* Program: CLIP_2 - Code from LIterate Program: 2-nd pass *) (* Purpose: Perform a run of the CLIP-system. *) (* Interface: CLIP.INI: File which contains all the information *) (* for this particular run. *) (* <sources>: Files containing the refinements. *) (* <modules>: Files containing the generated modules. *) (*********************************************************************) PROGRAM CLIP_2 (INPUT, OUTPUT); (*----------- Global parameters of the CLiP system ---------------*) CONST CLiP = 'Code from Literate Programs'; CLIP_VERSION = 'CLiP version 2.1'; (* Mod: EWvA 16/10/93 *) DFLT_INIFILE = 'CLIP.INI'; (* Mod: EWvA 16/10/93 *) DFLT_INIFILE_L = 8; (* Mod: EWvA 16/10/93 *) STRING_FIXED_L = 132; EMPTY_STRING_FIXED = ' '+ ' '+ ' '; MAX_FILE_SPEC_L = 132; MAX_NR_FILE_SPECS = 64; MAX_CHOICE_L = 100; ALLOWED_ID_CHARS = ['A'..'Z', 'a'..'z', '0'..'9', '.']; ERROR_MSG_LENGTH = 80; LOC_SPEC_L = 25; CORRUPT_INI_FILE = 1; (* Error_code used by CLIP_MNU *) FT_SIZE = MAX_NR_FILE_SPECS; MAX_LINE = 132; ST_SIZE = 30000; SP_SIZE = 65000; SYNTAX_LEN = 10; MAX_MODE_L = 16; MAX_M_D_L = 10; MAX_NR_SRC_FILES = MAX_NR_FILE_SPECS; MAX_NR_RSLT_MODULES = 10; MAX_EXTR_MODE_L = 9; MAX_FILE_EXT_L = 39; MAX_OPTION_LENGTH = 15; MAX_OPTIONS = 12; (*----------- Constants to assist implemention of ADTs -----------*) CONST MAX_NR_MESS = 35; MAX_ERROR = 100; CONST EMPTY_OPTION = ' '; (*----------- Global simple types of the CLiP system -------------*) TYPE TO_BE_DECIDED_LATER_ = (DEFINED,UNDEFINED); LONGINTEGER = -2147483647..2147483647; STRING_FIXED_ = PACKED ARRAY[1..STRING_FIXED_L] OF CHAR; FILE_MODE_ = (INSP_MODE, GEN_MODE); SPECIAL_CHOICE_ = CHAR; ALLOWED_ANSW_ = SET OF CHAR; ERROR_MSG_ = STRING_FIXED_; SEV_CODE_ = (WARN, ERR, FAIL, DUMP); LOC_SPEC_ = PACKED ARRAY[1..LOC_SPEC_L] OF CHAR; FT_INDEX_ = 0..FT_SIZE; ERROR_CODE_ = INTEGER; ST_INDEX_ = -1..ST_SIZE; SEGMENT_TYPE_ = (STUB, SLOT, CODE, END_STUB); SP_INDEX_ = -1..SP_SIZE; SYNTAX_STRING_ = STRING_FIXED_; MODE_ = STRING_FIXED_; MESSAGE_DESTINATION_ = STRING_FIXED_; EXTR_MODE_ = STRING_FIXED_; FILE_EXT_ = STRING_FIXED_; CATEGORY_ = (L1, L2, L3, L4, L5); SLT_PTR_ = ^SLOT_DES_; STB_PTR_ = ^STUB_DES_; SHADOW_PTR_ = ^SHADOW_LIST_; (*----------- Global structured types of the CLiP system ---------*) STRING132_ = RECORD BODY: STRING_FIXED_; LENGTH: INTEGER; END (*RECORD*); FILE_SPEC_ = RECORD LENGTH: INTEGER; BODY: STRING_FIXED_; END (*RECORD*); RSLT_MOD_SPEC_ = RECORD FILE_NAME: FILE_SPEC_; PATH: FILE_SPEC_; END (*RECORD*); SOURCE_FILES_ = ARRAY[1..MAX_NR_SRC_FILES] OF FILE_SPEC_; RSLT_MODULES_ = ARRAY[1..MAX_NR_RSLT_MODULES] OF RSLT_MOD_SPEC_; FILE_SPECS_ = RECORD NR_FILE_SPECS: INTEGER; FILES: SOURCE_FILES_; END (*RECORD*); LINE_DES_ = RECORD CHARS: STRING_FIXED_; INDENT: INTEGER; USED: INTEGER; ID: INTEGER; POS_OPTION_MARKER: INTEGER; END (*RECORD*); SEGMENT_DES_ = RECORD FIRST: ST_INDEX_; LAST: ST_INDEX_; END (*RECORD*); STRING_DES_ = RECORD FIRST: SP_INDEX_; LAST: SP_INDEX_; END (*RECORD*); SYNTAX_ = RECORD BODY: SYNTAX_STRING_; LENGTH: INTEGER; END (*RECORD*); RUN_INFO_ = RECORD CLIP_LPAR, CLIP_RPAR: SYNTAX_; CLIP_CC: CHAR; CLIP_END: SYNTAX_; OPTION_MARKER: CHAR; MODE: MODE_; INT_FAULT_CORR: BOOLEAN; MESSAGE_DESTINATION: MESSAGE_DESTINATION_; REPORT_FILE_SPEC: FILE_SPEC_; NR_SRC_FILES: INTEGER; SOURCE_FILES: SOURCE_FILES_; EXTR_MODE: EXTR_MODE_; NR_MODULES: INTEGER; RSLT_MODULES: RSLT_MODULES_; DFLT_EXT: FILE_EXT_; MODULE_DIRECTORY: FILE_SPEC_; END (*RECORD*); LINE_INFO_ = RECORD LINE_ID: STRING_DES_; CATEGORY: CATEGORY_; OPTIONS: BOOLEAN; END (*RECORD*); OPTIONS_ = RECORD QUICK, MULTIPLE, OPTIONAL, OVERRULE, LEADER, TRAILER, SEPARATOR, DEFAULT, LINENUMBER: BOOLEAN; INDENT, FILE_NAME, COMMENT: STRING_DES_; END (*RECORD*); STUB_DES_ = RECORD NAME: STRING_DES_ ; SRC_IMG: SEGMENT_DES_; OPTIONS: OPTIONS_ ; SLOTS: SLT_PTR_ ; NEXT_TWIN, NEXT_STUB: STB_PTR_ ; VISITED: BOOLEAN ; END (*RECORD*); SLOT_DES_ = RECORD NAME: STRING_DES_; SRC_IMG: SEGMENT_DES_; OPTIONS: OPTIONS_; STUB_REF: STB_PTR_; CODE: SEGMENT_DES_; NEXT_SLOT: SLT_PTR_; END (*RECORD*); CODE_STRUCT_ = RECORD FIRST_STUB: STB_PTR_; LAST_STUB: STB_PTR_; END (*RECORD*); SHADOW_LIST_ = RECORD STUB_POINTER: STB_PTR_; NEXT: SHADOW_PTR_; END (*RECORD*); (*----------- Types to assist implemention of ADTs ---------------*) TYPE SP_TYPE = RECORD CHARS: ARRAY[1..SP_SIZE] OF CHAR; USED : SP_INDEX_; END (*RECORD*); SP_PTR = ^SP_TYPE; TYPE OPTION_KEYWORD_ = PACKED ARRAY [1..MAX_OPTION_LENGTH] OF CHAR; (*----------- Global variables of the CLiP system ----------------*) VAR REPORT_FILE: TEXT; REPORT_OK: BOOLEAN; (*----------- Variables to assist implemention of ADTs -----------*) VAR START, STOP: LONGINTEGER; CONTINUE: BOOLEAN; RUN_INFO: RUN_INFO_; CODE_STRUCT: CODE_STRUCT_; (* STRING132: STRING132_; 22/10/93 *) (* DUMMY_LINE: LINE_DES_; 22/10/93 *) (* DUMMY_SEG: SEGMENT_DES_; 22/10/93 *) DUMMY_ERROR: INTEGER; INI_FILE: TEXT; EXT_FILE_SPEC: FILE_SPEC_; DUMMY_FILE_OK: BOOLEAN; DUMMY_ERROR_MSG: ERROR_MSG_; DUMMY_ERROR_CODE: INTEGER; ERROR_CODE: ERROR_CODE_; AUX_STRING_8: PACKED ARRAY[1..8] OF CHAR; I: INTEGER; ERROR_MSG : ERROR_MSG_; VAR FILE_TABLE: ARRAY[1..FT_SIZE] OF RECORD FILE_SPEC: FILE_SPEC_; FIRST: INTEGER; LAST: INTEGER; END (*RECORD*); LAST_LINE: INTEGER; LAST_FILE: FT_INDEX_; CURR_IN_FILE: TEXT; CURR_OUT_FILE: TEXT; SPACE: SET OF CHAR; VAR SEGMENT_TABLE: RECORD LINES: ARRAY [1..ST_SIZE] OF LINE_DES_; USED: ST_INDEX_; END (*RECORD*); LAST_READ_SEG: RECORD LAST_SEG: SEGMENT_DES_; LAST_LINE: ST_INDEX_; END (*RECORD*); VAR STRING_POOL: SP_PTR; BUFFER: STRING132_; VAR DIAG_TBL: ARRAY[1..MAX_NR_MESS] OF RECORD MESSAGE: STRING_FIXED_; MESS_LOC: LOC_SPEC_; MESS_L: INTEGER; END (*RECORD*); NO_MESSAGES: BOOLEAN; MSG_TBL: ARRAY[1..MAX_ERROR+1] OF RECORD SEV: SEV_CODE_; LOC: LOC_SPEC_; SOURCE_LINE: LINE_DES_; SEGMENT: SEGMENT_DES_; STRING132: STRING132_; LINE_ABS: INTEGER; END (*RECORD*); NR_MSG: INTEGER; VAR ALLOWED: SET OF CHAR; VAR OPTION_TABLE: ARRAY [1..MAX_OPTIONS] OF OPTION_KEYWORD_; OPT_SPACE: SET OF CHAR; OPT_CHARS: SET OF CHAR; DEFAULT_OPTIONS: OPTIONS_; PASCAL_STRING: STRING_FIXED_; FORTRAN_STRING: STRING_FIXED_; C_STRING: STRING_FIXED_; (*----------- Forward declarations -------------------------------*) PROCEDURE CLIP_STOP; FORWARD; PROCEDURE EXT_FILE_CLOSE( VAR FILE_VAR : TEXT; VAR ERROR_CODE: INTEGER); FORWARD; PROCEDURE EXT_FILE_PREP (VAR FILE_VAR: TEXT; EXT_FILE_SPEC: FILE_SPEC_; FILE_MODE: FILE_MODE_; VAR FILE_OK: BOOLEAN; VAR ERROR_CODE: INTEGER; VAR ERROR_MSG: ERROR_MSG_ ); FORWARD; PROCEDURE READ_FILE_SPEC (VAR AUX_FILE_SPEC: FILE_SPEC_; VAR FILE_SPEC_OK: BOOLEAN); FORWARD; PROCEDURE UC_WORD (VAR STR: PACKED ARRAY [ONE..LEN:INTEGER] OF CHAR); FORWARD; PROCEDURE WRITE_STRING (VAR OUT_FILE: TEXT; OUT_STRING: STRING_FIXED_; NR_CHARS: INTEGER); FORWARD; PROCEDURE WRLN_STRING (VAR OUT_FILE: TEXT; OUT_STRING: STRING_FIXED_; NR_CHARS: INTEGER; SPACE: INTEGER); FORWARD; FUNCTION CHECK_SYNTAX (LPAR, RPAR, END_STRING: SYNTAX_; CC, MARKER: CHAR): BOOLEAN; FORWARD; PROCEDURE INIT_RUN_INFO (VAR INIT_INFO: RUN_INFO_); FORWARD; PROCEDURE READ_INI_FILE (VAR INI_FILE: TEXT; VAR READ_INFO: RUN_INFO_; EXT_FILE_SPEC: FILE_SPEC_; VAR FILE_OK: BOOLEAN; VAR ERROR_MSG: ERROR_MSG_; VAR ERROR_CODE: INTEGER); FORWARD; PROCEDURE READ_LINE_SAFELY (VAR FILE_IN: TEXT); FORWARD; PROCEDURE READ_STRING (VAR IN_FILE: TEXT; VAR IN_STR_LN: INTEGER; VAR IN_STR_BODY: STRING_FIXED_; NR_CHARS_TO_READ: INTEGER); FORWARD; FUNCTION UC (INCHAR: CHAR): CHAR; FORWARD; PROCEDURE VAL_INI_DATA (VAR VAL_INFO: RUN_INFO_; VAR OK: BOOLEAN); FORWARD; FUNCTION FT_ABS_LINE_NUMBER (SOURCE_LINE: LINE_DES_): INTEGER; FORWARD; FUNCTION FT_CHECK_FILE (FILE_SPEC: FILE_SPEC_): ERROR_CODE_; FORWARD; FUNCTION FT_EOF: BOOLEAN; FORWARD; FUNCTION FT_GET_CHAR (SOURCE_LINE: LINE_DES_; INDEX: INTEGER): CHAR; FORWARD; PROCEDURE FT_GET_FILE_SPEC (SOURCE_LINE:LINE_DES_; VAR FILE_SPEC:FILE_SPEC_); FORWARD; FUNCTION FT_GET_INDENT (SOURCE_LINE: LINE_DES_): INTEGER; FORWARD; FUNCTION FT_GET_LINE_LENGTH (SOURCE_LINE: LINE_DES_): INTEGER; FORWARD; FUNCTION FT_GET_LINE_NUMBER (SOURCE_LINE: LINE_DES_): INTEGER; FORWARD; FUNCTION FT_GET_POS_OPTION_MARKER (SOURCE_LINE: LINE_DES_): INTEGER; FORWARD; FUNCTION FT_INCLOSE: ERROR_CODE_; FORWARD; PROCEDURE FT_INIT; FORWARD; PROCEDURE FT_INIT_LINE (VAR LINE: LINE_DES_); FORWARD; FUNCTION FT_INOPEN (FILE_SPEC: FILE_SPEC_): ERROR_CODE_; FORWARD; FUNCTION FT_OUTOPEN (FILE_SPEC: FILE_SPEC_): ERROR_CODE_; FORWARD; FUNCTION FT_OUTCLOSE: ERROR_CODE_; FORWARD; PROCEDURE FT_RDLN (VAR LINE: LINE_DES_); FORWARD; PROCEDURE FT_WRLN (VAR LINE: LINE_DES_; NR_BLANKS: INTEGER; DESTINATION: INTEGER); FORWARD; FUNCTION ST_ABS_SEG (SEGMENT: SEGMENT_DES_):INTEGER; FORWARD; PROCEDURE ST_GET_FILE_SPEC ( SEGMENT: SEGMENT_DES_; VAR FILE_SPEC: FILE_SPEC_); FORWARD; FUNCTION ST_GET_INDENT (SEG: SEGMENT_DES_): INTEGER; FORWARD; PROCEDURE ST_GET_LINE (VAR LINE: LINE_DES_); FORWARD; PROCEDURE ST_GET_OPTION_LINE (SEG: SEGMENT_DES_; VAR LINE: LINE_DES_); FORWARD; PROCEDURE ST_GET_SEG (SEG: SEGMENT_DES_; VAR LINE: LINE_DES_); FORWARD; PROCEDURE ST_GET_SEG_RANGE ( SEGMENT: SEGMENT_DES_; VAR FIRST, LAST:INTEGER); FORWARD; PROCEDURE ST_INIT; FORWARD; PROCEDURE ST_INIT_SEG (VAR SEG: SEGMENT_DES_); FORWARD; FUNCTION ST_IS_EMPTY_SEG (SEG: SEGMENT_DES_): BOOLEAN; FORWARD; FUNCTION ST_NUMBER_OF_LINES (SEG: SEGMENT_DES_): INTEGER; FORWARD; PROCEDURE ST_PUT_LINE (LINE: LINE_DES_; VAR SEG: SEGMENT_DES_); FORWARD; PROCEDURE ST_PUT_SEG (LINE: LINE_DES_; VAR SEG: SEGMENT_DES_); FORWARD; PROCEDURE ST_FINIT; FORWARD; FUNCTION ST_SEG_WIDTH (SEG: SEGMENT_DES_): INTEGER; FORWARD; PROCEDURE ST_WRITE_SEG (SEG: SEGMENT_DES_; BLANKS: INTEGER; DESTINATION: INTEGER); FORWARD; PROCEDURE SP_ADD_CHAR (CH: CHAR; VAR STR: STRING_DES_); FORWARD; PROCEDURE SP_CONC_STR (VAR MASTER: STRING_DES_; SLAVE: STRING_DES_); FORWARD; FUNCTION SP_EQ (STR1: STRING_DES_; STR2: STRING_DES_): BOOLEAN; FORWARD; PROCEDURE SP_EXTR_STR (STR: STRING_DES_; VAR STR132: STRING132_); FORWARD; FUNCTION SP_GET_CHAR (INDEX: INTEGER; STR: STRING_DES_): CHAR; FORWARD; PROCEDURE SP_INIT; FORWARD; PROCEDURE SP_INIT_STR (VAR STR: STRING_DES_); FORWARD; FUNCTION SP_IS_EMPTY_STR (STR: STRING_DES_): BOOLEAN; FORWARD; FUNCTION SP_LENGTH_STR (STR: STRING_DES_): INTEGER; FORWARD; PROCEDURE SP_ADD_BUFFER (VAR STR: STRING_DES_); FORWARD; PROCEDURE SP_ADD_BUFFER_CHAR (CH: CHAR); FORWARD; FUNCTION SP_GET_BUFFER_CHAR (INDEX: INTEGER): CHAR; FORWARD; PROCEDURE SP_INIT_BUFFER; FORWARD; (*----------- General routines -----------------------------------*) (*********************************************************************) (* Procedure: CLIP_STOP (VAX-version) *) (* Purpose: To halt a program without any message or dump. *) (*********************************************************************) PROCEDURE CLIP_STOP; BEGIN HALT END (*PROCEDURE CLIP_STOP*); (*********************************************************************) (* Routine: EXT_FILE_CLOSE (VAX-version) *) (* Purpose: To close an external file. *) (* Interface: FILE_VAR - Pascal file in question *) (* ERROR_CODE - Error indication to caller *) (*********************************************************************) PROCEDURE EXT_FILE_CLOSE; BEGIN CLOSE (FILE_VAR); ERROR_CODE := 0; END (*EXT_FILE_CLOSE*); (*********************************************************************) (* Procedure: EXT_FILE_PREP ( VAX-version ) *) (* Purpose: To prepare an external file for reading from it *) (* or writing to it. *) (* Interface: EXT_FILE_SPEC - VMS-file in question. *) (* FILE_MODE - Mode indicator. *) (* FILE_VAR - Pascal file in question. *) (* FILE_OK - Indicates succesfull preparation. *) (* ERROR_CODE - Error indication to caller. *) (* ERROR_MSG - Error message to caller. *) (*********************************************************************) PROCEDURE EXT_FILE_PREP; VAR AUX_FILE_SPEC: VARYING [MAX_FILE_SPEC_L] OF CHAR; BEGIN ERROR_CODE := -1; (* Initialization *) AUX_FILE_SPEC := EXT_FILE_SPEC.BODY; IF (FILE_MODE = INSP_MODE) THEN BEGIN IF (EXT_FILE_SPEC.LENGTH <> 0) THEN BEGIN (* First the file has to be opened. *) OPEN (FILE_VAR, AUX_FILE_SPEC, 'old', ERROR_CODE); IF ERROR_CODE = 0 THEN RESET (FILE_VAR); END (*IF*); END ELSE BEGIN (* FILE_MODE is gelijk aan GEN_MODE *) IF (EXT_FILE_SPEC.LENGTH <> 0) THEN BEGIN (* First the file has to be opened. *) OPEN (FILE_VAR, AUX_FILE_SPEC, 'unknown', ERROR_CODE); IF ERROR_CODE = 0 THEN REWRITE (FILE_VAR); END (*IF*); END (*IF*); (* DEFAULT CODE: *) IF NOT (ERROR_CODE = 0) THEN BEGIN FILE_OK := FALSE; (* This string is a bit too short for the assignment, *) (* but that is no problem in VAX-Pascal. *) CASE ERROR_CODE OF -1: BEGIN ERROR_MSG := 'Empty file name.'; END; 2: BEGIN ERROR_MSG := 'File not found.'; END; OTHERWISE ERROR_MSG := 'Unsuccesful performance'; END (*CASE*); END (*IF*) ELSE BEGIN FILE_OK := TRUE; ERROR_MSG := 'Succesful performance. '; ERROR_CODE := 0; END (*IF*); (* END DEFAULT CODE *) END (*EXT_FILE_PREP*); (*********************************************************************) (* Procedure: READ_FILE_SPEC *) (* Purpose: To read a filespecification from the terminal. *) (* Interface: AUX_FILE_SPEC - Returned file specification. *) (* FILE_SPEC_OK - File specification from terminal. *) (* Author/Date: Maarten Rooda, January 1991. *) (*********************************************************************) PROCEDURE READ_FILE_SPEC; VAR VAX_AUX_FILE_SPEC: VARYING [MAX_FILE_SPEC_L] OF CHAR; I: INTEGER; (* loopvariable. *) DUMMY_FILE: TEXT; FILE_OK: BOOLEAN; ERROR_CODE: INTEGER; ERROR_MSG: ERROR_MSG_; BEGIN FILE_SPEC_OK := TRUE; READLN (VAX_AUX_FILE_SPEC); FOR I := 1 TO LENGTH(VAX_AUX_FILE_SPEC) DO BEGIN AUX_FILE_SPEC.BODY[I] := VAX_AUX_FILE_SPEC[I]; END (*FOR*); AUX_FILE_SPEC.LENGTH := LENGTH(VAX_AUX_FILE_SPEC) END (*PROCEDURE READ_FILE_SPEC*); (*********************************************************************) (* Routine: UC_WORD *) (* Pupose: To convert a string to upper case . *) (* Interface: STRING - String to be converted *) (*********************************************************************) PROCEDURE UC_WORD; VAR COUNTER: INTEGER; BEGIN FOR COUNTER := ONE TO LEN DO STR[COUNTER] := UC (STR[COUNTER]); END (*UC_WORD*); (*********************************************************************) (* Procedure: WRITE_STRING (VAX-version) *) (* Purpose: Write a part of a text string to a text file *) (* Interface: OUT_FILE - The file that is written to *) (* NR_CHARS - The number of CHAR's that have to be *) (* written to the file *) (* OUT_STRING - The string to be written *) (* Author/date: Hans Rabouw, March 1992 *) (*********************************************************************) PROCEDURE WRITE_STRING; VAR I: INTEGER; BEGIN FOR I:= 1 TO NR_CHARS DO WRITE(OUT_FILE, OUT_STRING[I]); END; (*********************************************************************) (* Routine: WRLN_STRING - WRiTeLN STRING. (VAX-version) *) (* Purpose: Write a part of a text string to a text file and *) (* jump to the next line in the file after that. *) (* Interface: OUT_FILE - The file that is written to *) (* NR_CHARS - The number of CHAR's that have to be *) (* written to the file *) (* OUT_STRING - The string to be written *) (* SPACE - Number of spaces written before string. *) (* Author/date: Heleen Hollenberg, june 1992. *) (*********************************************************************) PROCEDURE WRLN_STRING; VAR I: INTEGER; BEGIN FOR I := 1 TO SPACE DO WRITE (OUT_FILE, ' ' ); FOR I:= 1 TO NR_CHARS DO WRITE (OUT_FILE, OUT_STRING[I]); WRITELN (OUT_FILE); END; (*********************************************************************) (* Routine: READ_LINE_SAFELY *) (* Purpose: To read a line from a file . *) (* Interface: FILE_IN - File to be read *) (* Author/date: Boudewijn Pelt, August 1991. *) (*********************************************************************) PROCEDURE READ_LINE_SAFELY; BEGIN IF NOT EOF (FILE_IN) THEN READLN (FILE_IN); END (*READ_LINE_SAFELY*); (*********************************************************************) (* Routine: CHECK_SYNTAX *) (* Purpose: To check the syntax parameters of CLIP. If they are *) (* not legal then the function result is FALSE *) (* Interface: LPAR - CLIP Left parenthesis definition *) (* RPAR - CLIP Right parenthesis definition *) (* END_STRING - End of stub indicator *) (* CC - CLIP Control Character *) (* MARKER - *) (* CHECK_SYNTAX - Show example of CLIP-syntax *) (* Author/date: Boudewijn Pelt, July 1991 *) (*********************************************************************) FUNCTION CHECK_SYNTAX; VAR COUNTER: INTEGER; ERROR: BOOLEAN; BEGIN ERROR := FALSE; FOR COUNTER := 1 TO SYNTAX_LEN DO IF MARKER IN [LPAR.BODY[COUNTER], RPAR.BODY[COUNTER], END_STRING.BODY[COUNTER]] THEN ERROR := TRUE; IF MARKER = CC THEN ERROR := TRUE; IF LPAR.BODY[LPAR.LENGTH] <> CC THEN ERROR := TRUE; IF RPAR.BODY[1] <> CC THEN ERROR := TRUE; WITH LPAR DO BEGIN IF LENGTH <= 1 THEN ERROR := TRUE; FOR COUNTER := 1 TO LENGTH DO IF BODY[COUNTER] IN ALLOWED_ID_CHARS THEN ERROR := TRUE; END (*WITH*); WITH RPAR DO BEGIN IF LENGTH <= 1 THEN ERROR := TRUE; FOR COUNTER := 1 TO LENGTH DO IF BODY[COUNTER] IN ALLOWED_ID_CHARS THEN ERROR := TRUE; END (*WITH*); WITH END_STRING DO BEGIN IF LENGTH <= 0 THEN ERROR := TRUE; FOR COUNTER := 1 TO LENGTH DO IF NOT (BODY[COUNTER] IN ALLOWED_ID_CHARS) THEN ERROR := TRUE; END (*WITH*); IF (CC IN ALLOWED_ID_CHARS) OR (CC = ' ') THEN ERROR := TRUE; IF (MARKER IN ALLOWED_ID_CHARS) OR (MARKER = ' ') THEN ERROR := TRUE; CHECK_SYNTAX := NOT ERROR; END (*CHECK_SYNTAX*); (*********************************************************************) (* Procedure: INIT_RUN_INFO . *) (* Purpose: To initialize the fields of a record INIT_INFO of *) (* type RUN_INFO_ to default values. *) (* Interface: INIT_INFO - Structure to initialize. *) (* Author/date: Maarten Rooda, January 1991. *) (*********************************************************************) PROCEDURE INIT_RUN_INFO; CONST AUX_STR_L = MAX_MODE_L; VAR I: INTEGER; AUX_STRING: PACKED ARRAY[1..AUX_STR_L] OF CHAR; BEGIN (******* INIT_RUN_INFO body *******) WITH INIT_INFO DO BEGIN (* additional parameters of init_info. *) CLIP_LPAR.BODY := EMPTY_STRING_FIXED; CLIP_LPAR.BODY[1] := '('; CLIP_LPAR.BODY[2] := '*'; CLIP_LPAR.BODY[3] := '*'; CLIP_LPAR.LENGTH := 3; CLIP_RPAR.BODY := EMPTY_STRING_FIXED; CLIP_RPAR.BODY[1] := '*'; CLIP_RPAR.BODY[2] := '*'; CLIP_RPAR.BODY[3] := ')'; CLIP_RPAR.LENGTH := 3; CLIP_END.BODY := EMPTY_STRING_FIXED; CLIP_END.BODY[1] := 'E'; CLIP_END.BODY[2] := 'N'; CLIP_END.BODY[3] := 'D'; CLIP_END.BODY[4] := 'O'; CLIP_END.BODY[5] := 'F'; CLIP_END.LENGTH := 5; CLIP_CC := '*'; OPTION_MARKER := '#'; (* old parameters. *) MODE := EMPTY_STRING_FIXED; AUX_STRING := 'INTERACTIVE_MODE'; FOR I := 1 TO MAX_MODE_L DO MODE[I] := AUX_STRING[I]; INT_FAULT_CORR := TRUE; MESSAGE_DESTINATION := EMPTY_STRING_FIXED; AUX_STRING := 'TERMINAL '; FOR I := 1 TO MAX_M_D_L DO MESSAGE_DESTINATION[I] := AUX_STRING[I]; REPORT_FILE_SPEC.BODY := EMPTY_STRING_FIXED; REPORT_FILE_SPEC.BODY[1] := 'C'; REPORT_FILE_SPEC.BODY[2] := 'L'; REPORT_FILE_SPEC.BODY[3] := 'I'; REPORT_FILE_SPEC.BODY[4] := 'P'; REPORT_FILE_SPEC.BODY[5] := '.'; REPORT_FILE_SPEC.BODY[6] := 'R'; REPORT_FILE_SPEC.BODY[7] := 'P'; REPORT_FILE_SPEC.BODY[8] := 'T'; REPORT_FILE_SPEC.LENGTH := 8; NR_SRC_FILES := 0; (* Default: *) EXTR_MODE := EMPTY_STRING_FIXED; AUX_STRING := 'OMITTED '; FOR I := 1 TO MAX_EXTR_MODE_L DO EXTR_MODE[I] := AUX_STRING[I]; NR_MODULES:= 0; MODULE_DIRECTORY.BODY := EMPTY_STRING_FIXED; MODULE_DIRECTORY.LENGTH := 0; END (* WITH INIT_INFO *); (***************** End of INIT_RUN_INFO body ***********************) END (*INIT_RUN_INFO*); (*********************************************************************) (* Procedure: READ_INI_FILE *) (* Purpose: To open an initializationfile and read data from *) (* it into a record READ_INFO of type RUN_INFO_ . *) (* Interface: INI_FILE: The initializationfile in question. *) (* READ_INFO: Information for a run of CLIP. *) (* EXT_FILE_SPEC: The filespecification *) (* FILE_OK: TRUE if data read successfully *) (* ERROR_MSG: Error message. *) (* ERROR_CODE: Type of error. *) (* Author/date: Maarten Rooda, February 1991. *) (*********************************************************************) PROCEDURE READ_INI_FILE; VAR DUMMY_CODE: INTEGER; (*********************************************************************) (* Procedure: READ_INI_DATA *) (* Purpose: To read data from an initializationfile into a *) (* record READ_INFO of type RUN_INFO_ . *) (* Interface: INI_FILE - INI-file to be read *) (* READ_INFO - Structure to return the data. *) (* Author/date: Boudewijn Pelt, May 1991. *) (*********************************************************************) PROCEDURE READ_INI_DATA(VAR INI_FILE: TEXT; VAR READ_INFO: RUN_INFO_); CONST SKIP_LINES = 5; VAR COUNTER: INTEGER; LETTER: STRING_FIXED_; (* This is an array that can be read by *) (* READ_STRING *) DUMMY_L: INTEGER; (* A dummy parameter for READ_STRING *) OK: BOOLEAN; AUX_STR_34 : PACKED ARRAY[1..34] OF CHAR; (*********************************************************************) (* Routine: GET_SOURCE_FILES *) (* Purpose: To read a number of filespecifications from an *) (* input file. *) (* Interface: FILE_IN - File with data to be read *) (* FILES - Data of files *) (* NR_FILES - Number of files *) (* Author/date: Boudewijn Pelt, August 1991 *) (* Modified: Hans Rabouw, March 1992 *) (*********************************************************************) PROCEDURE GET_SOURCE_FILES (VAR FILE_IN: TEXT; VAR FILES: SOURCE_FILES_; VAR NR_FILES: INTEGER); VAR I: INTEGER; READ_ON: BOOLEAN; AUX_FILE_SPEC: FILE_SPEC_; BEGIN I := 0; READ_ON := NOT (EOF (FILE_IN)); WHILE READ_ON DO BEGIN WITH AUX_FILE_SPEC DO READ_STRING(FILE_IN, LENGTH, BODY, MAX_FILE_SPEC_L); READ_LINE_SAFELY(INI_FILE); IF (AUX_FILE_SPEC.BODY[1] = '-') OR (AUX_FILE_SPEC.LENGTH = 0) THEN (* AUX_FILE_SPEC was not read successfully. *) READ_ON := FALSE ELSE IF I < MAX_NR_SRC_FILES THEN BEGIN (* AUX_FILE_SPEC was read successfully. *) I := I + 1; FILES[I] := AUX_FILE_SPEC; END (*IF.IF*); END (*WHILE*); NR_FILES := I; END (*GET_SOURCE_FILES*); (*********************************************************************) (* Routine: GET_MODULES *) (* Purpose: To read a number of filespecifications from an *) (* input file. *) (* Interface: FILE_IN - File with data to be read *) (* FILES - Data of files *) (* NR_FILES - Number of files *) (* Author/date: Boudewijn Pelt, August 1991 *) (* Modified: Hans Rabouw, March 1992 *) (*********************************************************************) PROCEDURE GET_MODULES (VAR FILE_IN: TEXT; VAR FILES: RSLT_MODULES_; VAR NR_FILES: INTEGER); VAR I: INTEGER; READ_ON: BOOLEAN; AUX_FILE_SPEC: FILE_SPEC_; AUX_PATH_SPEC: FILE_SPEC_; BEGIN I := 0; READ_ON := NOT (EOF (FILE_IN)); WHILE READ_ON DO BEGIN WITH AUX_PATH_SPEC DO READ_STRING(FILE_IN, LENGTH, BODY, MAX_FILE_SPEC_L); READ_LINE_SAFELY(INI_FILE); IF (AUX_PATH_SPEC.BODY[1] = '-') (* OR (AUX_PATH_SPEC.LENGTH = 0) (EWvA nav. HR 17/11/92) *) THEN (* AUX_PATH_SPEC was not read successfully. *) READ_ON := FALSE ELSE BEGIN WITH AUX_FILE_SPEC DO READ_STRING(FILE_IN, LENGTH, BODY, MAX_FILE_SPEC_L); READ_LINE_SAFELY(INI_FILE); IF (AUX_FILE_SPEC.BODY[1] = '-') OR (AUX_FILE_SPEC.LENGTH = 0) THEN READ_ON := FALSE ELSE IF I < MAX_NR_RSLT_MODULES THEN BEGIN (* AUX_FILE_SPEC was read successfully. *) I := I + 1; FILES[I].FILE_NAME := AUX_FILE_SPEC; FILES[I].PATH := AUX_PATH_SPEC; END (*IF.IF*); END (*IF*); END (*WHILE*); NR_FILES := I; END (*GET_MODULES*); BEGIN (******* READ_INI_DATA body *******) RESET (INI_FILE); FOR COUNTER := 1 TO SKIP_LINES DO READ_LINE_SAFELY(INI_FILE); WITH READ_INFO DO BEGIN (********************* READ_INI_DATA (1) ***********************) (** Read the data from INI_FILE into MODE, INT_FAULT_CORR, **) (** MESSAGE_DESTINATION, REPORT_FILE_SPEC, CLIP_LPAR, CLIP_- **) (** RPAR, CLIP_CC, CLIP_END, OPTION_MARKER, NR_SCR_FILES, **) (** SOURCE_FILES, NR_MODULES, EXTR_MODE, RSLT_MODULES. **) READ_STRING(INI_FILE, DUMMY_L, MODE, MAX_MODE_L); READ_LINE_SAFELY(INI_FILE); READ_STRING(INI_FILE, DUMMY_L, LETTER, 1); READ_LINE_SAFELY(INI_FILE); INT_FAULT_CORR := LETTER[1] = 'Y'; READ_STRING(INI_FILE, DUMMY_L, MESSAGE_DESTINATION, MAX_M_D_L); READ_LINE_SAFELY(INI_FILE); WITH CLIP_LPAR DO READ_STRING(INI_FILE, LENGTH, BODY, SYNTAX_LEN); READ_LINE_SAFELY(INI_FILE); WITH CLIP_RPAR DO READ_STRING(INI_FILE, LENGTH, BODY, SYNTAX_LEN); READ_LINE_SAFELY(INI_FILE); READ_STRING(INI_FILE, DUMMY_L, LETTER, 1); READ_LINE_SAFELY(INI_FILE); CLIP_CC := LETTER[1]; WITH CLIP_END DO READ_STRING(INI_FILE, LENGTH, BODY, SYNTAX_LEN); READ_LINE_SAFELY(INI_FILE); READ_STRING(INI_FILE, DUMMY_L, LETTER, 1); READ_LINE_SAFELY(INI_FILE); OPTION_MARKER := LETTER[1]; READ_STRING(INI_FILE, DUMMY_L, EXTR_MODE, MAX_EXTR_MODE_L); READ_LINE_SAFELY(INI_FILE); (************************ READ_INI_DATA (1.1) **********************) (** Read the file specifications REPORT_FILE_SPEC, **) (** SOURCE_FILES.FILES[1..NR_FILE_SPECS] **) (** RSLT_MODULES.FILES[1..NR_FILE_SPECS] from the INI_FILE. **) READ_LINE_SAFELY(INI_FILE); (* Skip -- REPORT FILE -- *) WITH REPORT_FILE_SPEC DO READ_STRING(INI_FILE, LENGTH, BODY, MAX_FILE_SPEC_L); READ_LINE_SAFELY(INI_FILE); READ_LINE_SAFELY(INI_FILE); (* skip -- INPUT FILES -- *) GET_SOURCE_FILES (INI_FILE, SOURCE_FILES, NR_SRC_FILES); GET_MODULES (INI_FILE, RSLT_MODULES, NR_MODULES); (* There is no need to skip the '--- MODULE DIRECTORY ---' line *) (* because it is read by the GET_MODULES procedure *) WITH MODULE_DIRECTORY DO READ_STRING(INI_FILE, LENGTH, BODY, MAX_FILE_SPEC_L); (***************** End of READ_INI_DATA (1.1) **********************) (************************ READ_INI_DATA (1.2) **********************) (** CLIP_LPAR and CLIP_RPAR are not complete. An CLIP_CC needs to **) (** be added. **) WITH CLIP_LPAR DO BEGIN IF LENGTH < SYNTAX_LEN THEN LENGTH := LENGTH + 1; BODY[LENGTH] := CLIP_CC; END (*WITH*); WITH CLIP_RPAR DO BEGIN LENGTH := LENGTH + 1; IF LENGTH > SYNTAX_LEN THEN LENGTH := SYNTAX_LEN; FOR COUNTER := LENGTH-1 DOWNTO 1 DO BODY[COUNTER+1] := BODY[COUNTER]; BODY[1] := CLIP_CC; END (*WITH*); (****************** End of READ_INI_DATA (1.2) *********************) (***************** End of READ_INI_DATA (1) ********************) END (*WITH*); (************************* READ_INI_DATA (2) ***********************) (** Check if READ_INFO is valid. If not display an error message **) (** and set READ_INFO to default values. **) VAL_INI_DATA (READ_INFO, OK); IF NOT OK THEN BEGIN (********************* READ_INI_DATA (2.1) *********************) (** Generate a warning message **) ERROR_CODE := CORRUPT_INI_FILE; ERROR_MSG := EMPTY_STRING_FIXED; AUX_STR_34 := 'THE SPECIFIED INI-FILE IS CORRUPT.'; FOR COUNTER := 1 TO 34 DO ERROR_MSG[COUNTER] := AUX_STR_34[COUNTER]; (***************** End of READ_INI_DATA (2.1) ******************) INIT_RUN_INFO(READ_INFO); END (*IF*); (********************* End of READ_INI_DATA (2) ********************) (***************** End of READ_INI_DATA body ***********************) END (*READ_INI_DATA*); BEGIN FILE_OK := FALSE; EXT_FILE_PREP(INI_FILE, EXT_FILE_SPEC, INSP_MODE, FILE_OK, ERROR_CODE, ERROR_MSG); IF FILE_OK THEN BEGIN READ_INI_DATA (INI_FILE, READ_INFO); (* If the INI-file contained an error, the READ_INFO record *) (* was initialized by READ_INI_DATA. *) EXT_FILE_CLOSE (INI_FILE, DUMMY_CODE); (* EWvA, 16/10/93 *) END (*IF*); END (*READ_INI_FILE*); (*********************************************************************) (* Procedure: READ_STRING *) (* Purpose: read a string from a text file and determine its *) (* length. *) (* Interface: IN_FILE - File to be read *) (* IN_STR_LN - Index in line to be read *) (* IN_STR_BODY - Body of the line *) (* Author/date: Maarten Rooda, September 1990. *) (* Modified: Boudewijn Pelt, June 1991 & July 1991. *) (* Hans Rabouw, March 1992 *) (*********************************************************************) PROCEDURE READ_STRING; VAR INDEX: INTEGER; BEGIN (* File is already open and in inspection mode. *) (* A prompt, if needed, has already been issued. *) IN_STR_LN := 0; INDEX := 1; IF NOT (EOF(IN_FILE)) OR (EOLN (IN_FILE)) THEN BEGIN WHILE NOT (EOLN (IN_FILE) OR (INDEX > NR_CHARS_TO_READ)) DO BEGIN READ(IN_FILE, IN_STR_BODY[INDEX]); INDEX := INDEX + 1; END (*WHILE*); IN_STR_LN := INDEX - 1; IF IN_STR_LN > 0 THEN WHILE (IN_STR_BODY[IN_STR_LN] = ' ') AND (IN_STR_LN > 1) DO IN_STR_LN := IN_STR_LN - 1; (* If not all of the string has been filled, write spaces to *) (* the cells that have not been filled. *) FOR INDEX := INDEX TO STRING_FIXED_L DO IN_STR_BODY[INDEX] := ' '; END (*IF*); END (*READ_STRING*); (*********************************************************************) (* Routine: UC - convert character to Upper-Case *) (* Purpose: To transform lower case letters to their uppercase *) (* equivalent. *) (* Interface: INCHAR - Character to be converted. *) (* <RETURNS> - Converted character. *) (* Author/Date: Vamp project management, october 1983. *) (*********************************************************************) FUNCTION UC; BEGIN IF (INCHAR >= 'a') AND (INCHAR <= 'z') THEN UC := CHR (ORD(INCHAR) - ORD('a') + ORD('A')) ELSE UC := INCHAR; END (*UC*); (*********************************************************************) (* Routine: VAL_INI_DATA *) (* Purpose: Check if the run_info structure VAL_INFO is valid *) (* if this is not the case then attempt to fix it *) (* or return an error. (Make OK FALSE) *) (* Interface: VAL_INFO - Data from initialization. *) (* OK - TRUE if data OK. *) (* Author/date: Boudewijn Pelt, June 1991. *) (*********************************************************************) PROCEDURE VAL_INI_DATA; CONST AUX_STR_L = MAX_MODE_L; VAR ERROR: BOOLEAN; AUX_STRING: PACKED ARRAY [1..AUX_STR_L] OF CHAR; I: INTEGER; BEGIN ERROR := FALSE; WITH VAL_INFO DO BEGIN IF NOT (CHECK_SYNTAX(CLIP_LPAR, CLIP_RPAR, CLIP_END, CLIP_CC, OPTION_MARKER)) THEN ERROR := TRUE; (* Check MODE and set ERROR. *) IF MODE[1] IN ['I', 'i'] THEN AUX_STRING :='INTERACTIVE_MODE' ELSE IF MODE[1] IN ['A', 'a'] THEN AUX_STRING :='AUTO_MODE ' ELSE IF MODE[1] IN ['H', 'h'] THEN AUX_STRING :='HELPFUL_MODE ' ELSE IF MODE[1] IN ['D', 'd'] THEN AUX_STRING :='DEBUG_MODE ' ELSE ERROR := TRUE; IF NOT ERROR THEN FOR I := 1 TO MAX_MODE_L DO MODE[I] := AUX_STRING[I]; (* Check MESSAGE_DESTINATION and set ERROR. *) IF MESSAGE_DESTINATION[1] IN ['F', 'f'] THEN AUX_STRING := 'FILE ' ELSE IF MESSAGE_DESTINATION[1] IN ['T', 't'] THEN AUX_STRING := 'TERMINAL ' ELSE IF MESSAGE_DESTINATION[1] IN ['B', 'b'] THEN AUX_STRING := 'BOTH ' ELSE IF MESSAGE_DESTINATION[1] IN ['N', 'n'] THEN AUX_STRING := 'NONE ' ELSE ERROR := TRUE; IF NOT ERROR THEN FOR I := 1 TO MAX_M_D_L DO MESSAGE_DESTINATION[I] := AUX_STRING[I]; (* Check EXTR_MODE and set ERROR. *) IF EXTR_MODE[1] IN ['E', 'e'] THEN AUX_STRING := 'EXTRACTED ' ELSE IF EXTR_MODE[1] IN ['O', 'o'] THEN AUX_STRING := 'OMITTED ' ELSE ERROR := TRUE; IF NOT ERROR THEN FOR I := 1 TO MAX_EXTR_MODE_L DO EXTR_MODE[I] := AUX_STRING[I]; END (*WITH*); OK := NOT ERROR; END (*VAL_INI_DATA*); (*----------- File Table routines (ADT) --------------------------*) (*********************************************************************) (* Routine: FT_ABS_LINE_NUMBER - File Table ABSolute LINE NUMBER.*) (* Purpose: To return the absolute line number of a source line *) (* the source file. *) (* Interface: SOURCE_LINE - The specified source line. *) (* RETURNS - Absolute line number of the given *) (* SOURCE_LINE. *) (*********************************************************************) FUNCTION FT_ABS_LINE_NUMBER; BEGIN FT_ABS_LINE_NUMBER := SOURCE_LINE.ID; END (*FUNCTION FT_ABS_LINE_NUMBER*); (*********************************************************************) (* Routine: FT_CHECK_FILE *) (* Purpose: Checks whether a file is acccessable or not. *) (* Interface: FILE_SPEC - Specification of file to check. *) (* RETURNS - Code of a possible error. *) (* FT vars: CURR_IN_FILE. *) (*********************************************************************) FUNCTION FT_CHECK_FILE; VAR ERROR_CODE: ERROR_CODE_; DUMMY_FILE_OK: BOOLEAN; DUMMY_ERROR_MSG: ERROR_MSG_; BEGIN EXT_FILE_PREP (CURR_IN_FILE, FILE_SPEC, INSP_MODE, DUMMY_FILE_OK, ERROR_CODE, DUMMY_ERROR_MSG); IF ERROR_CODE<=0 THEN CLOSE (CURR_IN_FILE); FT_CHECK_FILE := ERROR_CODE; END (*FT_CHECK_FILE*); (*********************************************************************) (* Routine: FT_EOF *) (* Purpose: The function examines if the currently read file is *) (* exhausted. *) (* Interface: RETURNS - TRUE if the file is exhausted. *) (* FT vars: CURR_IN_FILE. *) (*********************************************************************) FUNCTION FT_EOF; BEGIN IF NOT EOF(CURR_IN_FILE) THEN FT_EOF := FALSE ELSE FT_EOF := TRUE; END (*FT_EOF*); (*********************************************************************) (* Routine: FT_GET_CHAR *) (* Purpose: To locate a character at a given position in a *) (* source_line and to return this character. *) (* Interface: SOURCE_LINE - The source line. *) (* INDEX - Index of the desired character. *) (* RETURNS - The desired character. *) (* CLIP objs: MAX_LINE. *) (*********************************************************************) FUNCTION FT_GET_CHAR; BEGIN IF (INDEX > MAX_LINE) OR (INDEX <= 0) THEN BEGIN WRITELN (OUTPUT, 'FT-GET-CHAR (a): ', 'System Failure... Call maintenance.'); CLIP_STOP; END (*IF*); IF INDEX > SOURCE_LINE.USED THEN BEGIN WRITELN (OUTPUT, 'FT-GET-CHAR (B): ', 'System Failure... Call maintenance.'); CLIP_STOP; END (*IF*); (* Index is within legal range. Proceed... *) FT_GET_CHAR := SOURCE_LINE.CHARS[INDEX]; END (*FT_GET_CHAR*); (*********************************************************************) (* Routine: FT_GET_FILE_SPEC *) (* Purpose: To return the file specification of a source line *) (* Interface: SOURCE_LINE - The source line. *) (* FILE_SPEC - The wanted file specification. *) (* FT vars: FILE_TABLE. *) (*********************************************************************) PROCEDURE FT_GET_FILE_SPEC; VAR INDEX: FT_INDEX_; BEGIN (* Beware of non-existing line identifications. *) IF (SOURCE_LINE.ID <= 0) OR (SOURCE_LINE.ID > FILE_TABLE[LAST_FILE].LAST) THEN BEGIN WRITELN (OUTPUT, 'FT-GET-FILE-SPEC: ', 'System Failure... Call maintenance.'); CLIP_STOP; END (*IF*); (* Line surely exist in FT. Find its specification. *) INDEX := 1; WHILE FILE_TABLE[INDEX].LAST < SOURCE_LINE.ID DO INDEX := INDEX+1; FILE_SPEC := FILE_TABLE[INDEX].FILE_SPEC; END (*FT_GET_FILE_SPEC*); (*********************************************************************) (* Routine: FT_GET_INDENT *) (* Purpose: To return the indentation of a line *) (* Interface: SOURCE_LINE - The source line. *) (* RETURNS - The indentation of SOURCE_LINE. *) (*********************************************************************) FUNCTION FT_GET_INDENT; BEGIN FT_GET_INDENT := SOURCE_LINE.INDENT; END (*FT_GET_INDENT*); (*********************************************************************) (* Routine: FT_GET_LINE_LENGTH *) (* Purpose: To return the length of a line *) (* Interface: SOURCE_LINE - Line-descriptor to be examined. *) (* RETURNS - Length of given line. *) (*********************************************************************) FUNCTION FT_GET_LINE_LENGTH; BEGIN FT_GET_LINE_LENGTH := SOURCE_LINE.USED; END (*FT_GET_LINE_LENGTH*); (*********************************************************************) (* Routine: FT_GET_LINE_NUMBER *) (* Purpose: To return the line number of a source line. *) (* Interface: SOURCE_LINE - The source line *) (* RETURNS - Line number or error code. *) (* FT vars: FILE_TABLE. *) (*********************************************************************) FUNCTION FT_GET_LINE_NUMBER; VAR INDEX: FT_INDEX_; BEGIN (* Beware of non-existing line identifications. *) IF (SOURCE_LINE.ID <= 0) OR (SOURCE_LINE.ID > FILE_TABLE[LAST_FILE].LAST) THEN BEGIN WRITELN (OUTPUT, 'FT_GET_LINE_NUMBER: ', 'System Failure... Call maintenance.'); CLIP_STOP; END (*IF*); (* Line surely exist in FT. Find its number. *) INDEX := 1; WHILE FILE_TABLE[INDEX].LAST < SOURCE_LINE.ID DO INDEX := INDEX + 1; FT_GET_LINE_NUMBER := SOURCE_LINE.ID - FILE_TABLE[INDEX].FIRST + 1; END (*FT_GET_LINE_NUMBER*); (*********************************************************************) (* Routine: FT_GET_POS_OPTION_MARKER *) (* Purpose: Return the value of POS_OPTION_MARKER. *) (* Interface: SOURCE_LINE - Line-descriptor to be examined. *) (* RETURNS - Position of the OPTION_MARKER. *) (*********************************************************************) FUNCTION FT_GET_POS_OPTION_MARKER; BEGIN FT_GET_POS_OPTION_MARKER := SOURCE_LINE.POS_OPTION_MARKER; END (*FT_GET_POS_MARKER*); (*********************************************************************) (* Routine: FT_INCLOSE *) (* Purpose: Close the current input file. *) (* Interface: RETURNS - Code of a possible error. *) (* FT vars: CURR_IN_FILE. *) (*********************************************************************) FUNCTION FT_INCLOSE; VAR ERROR_CODE: ERROR_CODE_; BEGIN EXT_FILE_CLOSE (CURR_IN_FILE, ERROR_CODE); FT_INCLOSE := ERROR_CODE; END (*FT_INCLOSE*); (*********************************************************************) (* Routine: FT_INIT *) (* Purpose: General initialization of the file table. It is only *) (* activated once at the start of an run. *) (* FT vars: FILE_TABLE, LAST_LINE, LAST_FILE, SPACE. *) (*********************************************************************) PROCEDURE FT_INIT; VAR K: FT_INDEX_; BEGIN FOR K := 1 TO FT_SIZE DO WITH FILE_TABLE[K] DO BEGIN FILE_SPEC.LENGTH := 0; FIRST := 0; LAST := 0; END (*WITH*); LAST_LINE := 0; LAST_FILE := 0; SPACE := [CHR(0) .. CHR(9), CHR(14) .. CHR(25), CHR(28) .. CHR(32), CHR(11), CHR(127)]; END (*FT_INIT*); (*********************************************************************) (* Routine: FT_INIT_LINE *) (* Purpose: Initialization of a LINE_DES_-object. *) (*********************************************************************) PROCEDURE FT_INIT_LINE; BEGIN WITH LINE DO BEGIN INDENT := 0; USED := 0; ID := 0; POS_OPTION_MARKER := 0; END (*WITH*); END (*FT_INIT_LINE*); (*********************************************************************) (* Routine: FT_INOPEN *) (* Purpose: Opens a new file with the given specification for *) (* read access. *) (* Interface: FILE_SPEC - Specification of file to open. *) (* RETURNS - Code of a possible error. *) (* FT vars: FILE_TABLE, LAST_FILE, CURR_IN_FILE. *) (*********************************************************************) FUNCTION FT_INOPEN; VAR ERROR_CODE: ERROR_CODE_; DUMMY_FILE_OK: BOOLEAN; DUMMY_ERROR_MSG: ERROR_MSG_; BEGIN EXT_FILE_PREP (CURR_IN_FILE, FILE_SPEC, INSP_MODE, DUMMY_FILE_OK, ERROR_CODE, DUMMY_ERROR_MSG); IF ERROR_CODE = 0 THEN BEGIN LAST_FILE := LAST_FILE+1; FILE_TABLE[LAST_FILE].FILE_SPEC := FILE_SPEC; END (*IF*); FT_INOPEN := ERROR_CODE; END (*FT_INOPEN*); (*********************************************************************) (* Routine: FT_OUTOPEN *) (* Purpose: Opens a new file with the given specification for *) (* write access. *) (* Interface: FILE_SPEC - Specification of outputfile. *) (* RETURNS - Code of a possible error. *) (* FT vars: CURR_OUT_FILE. *) (*********************************************************************) FUNCTION FT_OUTOPEN; VAR ERROR_CODE: ERROR_CODE_; DUMMY_FILE_OK: BOOLEAN; DUMMY_ERROR_MSG: ERROR_MSG_; BEGIN EXT_FILE_PREP (CURR_OUT_FILE, FILE_SPEC, GEN_MODE, DUMMY_FILE_OK, ERROR_CODE, DUMMY_ERROR_MSG); (* The opening was successfull. Make ERROR_CODE equal to *) (* STATUS (CURR_OUT_FILE) in case an error occured during the *) (* REWRITE operation (flagged by a value <> -1). *) FT_OUTOPEN := ERROR_CODE; END (*FT_OUTOPEN*); (*********************************************************************) (* Routine: FT_OUTCLOSE *) (* Purpose: Close the current output file. *) (* Interface: RETURNS - Code of a possible error. *) (* FT vars: CURR_OUT_FILE. *) (*********************************************************************) FUNCTION FT_OUTCLOSE; VAR ERROR_CODE: ERROR_CODE_; BEGIN EXT_FILE_CLOSE (CURR_OUT_FILE, ERROR_CODE); FT_OUTCLOSE := ERROR_CODE; END (*FT_OUTCLOSE*); (*********************************************************************) (* Routine: FT_RDLN *) (* Purpose: Read the next line from the current source-file. *) (* Interface: LINE - A source-line is returned in the form of a *) (* line descriptor. *) (* FT vars: SPACE *) (*********************************************************************) PROCEDURE FT_RDLN; CONST TAB = 8; VAR STR132: STRING132_; INDEX, K: INTEGER; BEGIN WITH LINE DO BEGIN INDENT := 0; USED := 0; POS_OPTION_MARKER := 0; WITH STR132 DO BEGIN BODY := EMPTY_STRING_FIXED; LENGTH := 0; WHILE (NOT EOLN(CURR_IN_FILE)) AND (LENGTH < STRING_FIXED_L) DO BEGIN LENGTH := LENGTH + 1; READ (CURR_IN_FILE, BODY[LENGTH]); END (*WHILE*); READLN (CURR_IN_FILE); (* Check spaces at beginning of string and calculate *) (* INDENT. *) INDEX := 1; WHILE (INDEX < LENGTH) AND (BODY[INDEX] IN SPACE) DO BEGIN IF BODY[INDEX] = CHR(9) THEN INDENT := INDENT + (TAB - (INDENT MOD TAB)) ELSE INDENT := INDENT + 1; INDEX := INDEX + 1; END (*WHILE*); LAST_LINE := LAST_LINE + 1; FOR K := INDEX TO LENGTH DO CHARS[K-INDEX+1] := BODY[K]; (* Remove spaces at the end of the line. *) IF LENGTH > 0 THEN BEGIN USED := LENGTH-INDEX+1; (*********************************************************************) (* Modified 14/10/93 by Mark Kramer to solve an index out of bound *) (* problem when bound checks are on. *) (* WHILE (USED >0) AND (CHARS[USED] IN SPACE) DO *) (* USED := USED-1; *) WHILE (USED > 1) AND (CHARS[USED] IN SPACE) DO USED := USED-1; IF (USED = 1) AND (CHARS[USED] IN SPACE) THEN USED := USED-1; (* End of modification 14/10/93. *) (*********************************************************************) END (*IF*); ID := LAST_LINE; END (*WITH*); (* Update the File Table. *) IF FILE_TABLE[LAST_FILE].FIRST = 0 THEN FILE_TABLE[LAST_FILE].FIRST := LAST_LINE; FILE_TABLE[LAST_FILE].LAST := LAST_LINE; END (*WITH*); END (*FT_RDLN*); (*********************************************************************) (* Routine: FT_WRLN *) (* Purpose: Write a line to the current output file. *) (* Interface: LINE - The line to be written. *) (* NR_BLANKS - The number of blanks leading the *) (* first character of LINE. *) (* DESTINATION - The destination of the line (screen, *) (* output file, reportfile etc.) *) (* REPORT_FILE - Report file for output. *) (*********************************************************************) PROCEDURE FT_WRLN; VAR INDEX: INTEGER; NR_TOTAL_BLANKS: INTEGER; BEGIN (*FT_WRLN*) NR_TOTAL_BLANKS := LINE.INDENT + NR_BLANKS; CASE DESTINATION OF 0: BEGIN FOR INDEX := 1 TO LINE.USED DO WRITE (OUTPUT, LINE.CHARS[INDEX]); WRITELN (OUTPUT); END; 1: BEGIN WRLN_STRING (CURR_OUT_FILE, LINE.CHARS, LINE.USED, NR_TOTAL_BLANKS); END; 2: BEGIN FOR INDEX := 1 TO LINE.USED DO WRITE (OUTPUT, LINE.CHARS[INDEX]); WRITELN (OUTPUT); END; 3: BEGIN WRLN_STRING (REPORT_FILE, LINE.CHARS, LINE.USED, 0); END; END (*CASE*); END (*FT_WRLN*); (*----------- Segment Table routines (ADT) -----------------------*) (*********************************************************************) (* Routine: ST_RD - Segment Table ReaD. *) (* Purpose: Read a line from the SEGMENT_TABLE. *) (* Interface: LINE - The line which is read. *) (* INDEX - The position of the line in SEGMENT_TABLE. *) (* ST vars: SEGMENT_TABLE. *) (*********************************************************************) PROCEDURE ST_RD (VAR LINE: LINE_DES_; INDEX: ST_INDEX_); BEGIN LINE := SEGMENT_TABLE.LINES[INDEX]; END (*ST_READ*); (*********************************************************************) (* Routine: ST_WR - Segment Table WRite. *) (* Purpose: Write a line to the SEGMENT_TABLE. *) (* Interface: LINE - The line which is written *) (* INDEX- The position of the LINE. *) (* ST var: SEGMENT_TABLE. *) (*********************************************************************) PROCEDURE ST_WR (LINE: LINE_DES_; INDEX: ST_INDEX_); BEGIN SEGMENT_TABLE.LINES[INDEX] := LINE; END (*ST_WR*); (*********************************************************************) (* Routine: ST_ABS_SEG - Segment Table ABSolute SEGment *) (* Purpose: To return the absolute line number of the first *) (* line of the segment. *) (* Interface: SEGMENT - Given segment *) (* Function result - The absolute line number of the *) (* first line of SEGMENT. *) (* ST vars: SEGMENT_TABLE. *) (*********************************************************************) FUNCTION ST_ABS_SEG; VAR LINE: LINE_DES_; BEGIN IF SEGMENT.FIRST > 0 THEN BEGIN ST_RD (LINE, SEGMENT.FIRST); ST_ABS_SEG := FT_ABS_LINE_NUMBER (LINE); END (*IF*) END (*ST_ABS_SEG*); (*********************************************************************) (* Routine: ST_GET_FILE_SPEC *) (* Purpose: To return the file specification of the source file *) (* of the segment. *) (* Interface: SEGMENT - Given segment. *) (* FILE_SPEC - The file specification. *) (* ST vars: SEGMENT_TABLE. *) (*********************************************************************) PROCEDURE ST_GET_FILE_SPEC; VAR LINE: LINE_DES_; BEGIN ST_RD (LINE, SEGMENT.FIRST); FT_GET_FILE_SPEC (LINE, FILE_SPEC); END (*ST_GET_FILE_SPEC*); (*********************************************************************) (* Routine: ST_GET_INDENT *) (* Purpose: Return the indentation of segment. *) (* Interface: SEG - Segment to be investigated. *) (* RETURNS - Indent value or error-code. *) (*********************************************************************) FUNCTION ST_GET_INDENT; VAR LINE: LINE_DES_; BEGIN ST_RD (LINE, SEG.FIRST); ST_GET_INDENT := FT_GET_INDENT (LINE); END (*ST_GET_INDENT*); (*********************************************************************) (* Routine: ST_GET_LINE *) (* Purpose: Retrieves next line from the currently read segment. *) (* Interface: LINE - Returned line. *) (* ST vars: SEGMENT_TABLE, LAST_READ_SEG. *) (*********************************************************************) PROCEDURE ST_GET_LINE; VAR INDEX: ST_INDEX_; BEGIN WITH LAST_READ_SEG DO BEGIN IF ST_IS_EMPTY_SEG (LAST_SEG) THEN BEGIN (* ST_GET_LINE has not properly been prepared for reading.*) WRITELN (OUTPUT, 'ST-GET-LN: ', 'System Failure... Call maintenance.'); CLIP_STOP; END ELSE BEGIN INDEX := LAST_LINE + 1; IF INDEX > LAST_SEG.LAST THEN BEGIN (* Segment exhausted. Return LINE with ID value 0. *) LINE.ID := 0; END ELSE BEGIN (* Retrieve line at position INDEX from the ST and *) (* update LAST_READ_SEG. *) ST_RD (LINE, INDEX); LAST_LINE := INDEX; END (*IF*); END (*IF*); END (*WITH*); END (*ST_GET_LINE*); (*********************************************************************) (* Routine: ST_GET_OPTION_LINE *) (* Purpose: To retrieve the first line from a segment which *) (* holds an option marker. *) (* Interface: SEG - The segment *) (* LINE - The first line holding an option marker *) (* ST vars: SEGMENT_TABLE, LAST_READ_SEG. *) (*********************************************************************) PROCEDURE ST_GET_OPTION_LINE; VAR INDEX: ST_INDEX_; POSITION: INTEGER; AUX_LINE: LINE_DES_; BEGIN INDEX := SEG.FIRST; POSITION := 0; IF INDEX > 0 THEN BEGIN WHILE (POSITION =0) AND (INDEX <= SEG.LAST) DO BEGIN ST_RD (AUX_LINE, INDEX); POSITION := FT_GET_POS_OPTION_MARKER (AUX_LINE); IF POSITION =0 THEN INDEX := INDEX + 1; END (*WHILE*); IF POSITION =0 THEN LINE.ID := 0 ELSE LINE := AUX_LINE; WITH LAST_READ_SEG DO BEGIN LAST_SEG := SEG; LAST_LINE := INDEX; END (*WITH*); END ELSE BEGIN LAST_READ_SEG.LAST_SEG.FIRST := 0; LAST_READ_SEG.LAST_SEG.LAST := 0; LAST_READ_SEG.LAST_LINE := 0; LINE.ID := 0; END (*IF*); END (*ST_GET_OPTION_LINE*); (*********************************************************************) (* Routine: ST_GET_SEG *) (* Purpose: Retrieve the first line of a given segment from ST. *) (* Interface: LINE - Returned line. *) (* SEG - Segment to read from. *) (* ST vars: SEGMENT_TABLE, LAST_READ_SEG. *) (*********************************************************************) PROCEDURE ST_GET_SEG; BEGIN IF ST_IS_EMPTY_SEG (SEG) THEN BEGIN (* Return virtual line and reset LAST_READ_SEG. *) LINE.ID := 0; ST_INIT_SEG (LAST_READ_SEG.LAST_SEG); LAST_READ_SEG.LAST_LINE := 0; END ELSE BEGIN ST_RD (LINE, SEG.FIRST); WITH LAST_READ_SEG DO BEGIN LAST_SEG := SEG; LAST_LINE := SEG.FIRST; END (*WITH*); END (*IF*); END (*ST_GET_SEG*); (*********************************************************************) (* Routine: ST_GET_SEG_RANGE - Segment Table SEGMENT RANGE *) (* Purpose: To return the first and last relative line number of *) (* a segment. *) (* Interface: SEGMENT - Given segment. *) (* FIRST - The line number of the first segment line. *) (* LAST - The line number of the last segment line. *) (* ST vars: SEGMENT_TABLE. *) (*********************************************************************) PROCEDURE ST_GET_SEG_RANGE; VAR LINE: LINE_DES_; BEGIN FIRST := 0; LAST := 0; IF SEGMENT.FIRST > 0 THEN BEGIN ST_RD (LINE, SEGMENT.FIRST); FIRST := FT_GET_LINE_NUMBER (LINE); ST_RD (LINE, SEGMENT.LAST); LAST := FT_GET_LINE_NUMBER (LINE); END (*IF*); END (*ST_GET_SEG_RANGE*); (*********************************************************************) (* Routine: ST_INIT *) (* Purpose: General initialization of the segment table. To be *) (* invoked only once at the beginning of a run. *) (* ST vars: SEGMENT_TABLE, LAST_READ_SEG. *) (*********************************************************************) PROCEDURE ST_INIT; BEGIN SEGMENT_TABLE.USED := 0; ST_INIT_SEG (LAST_READ_SEG.LAST_SEG); LAST_READ_SEG.LAST_LINE := 0; END (*ST_INIT*); (*********************************************************************) (* Routine: ST_INIT_SEG *) (* Purpose: To establish a new and empty segment. *) (* Interface: SEG - the segment to initialize. *) (*********************************************************************) PROCEDURE ST_INIT_SEG; BEGIN SEG.FIRST := 0; SEG.LAST := -1; END (*ST_INIT_SEG*); (*********************************************************************) (* Routine: ST_IS_EMPTY_SEG *) (* Purpose: To examine if a segment is empty or not. *) (* Interface: SEG - Segment to be examined. *) (*********************************************************************) FUNCTION ST_IS_EMPTY_SEG; BEGIN ST_IS_EMPTY_SEG := (ST_NUMBER_OF_LINES (SEG) <= 0); END (*ST_IS_EMPTY_SEG*); (*********************************************************************) (* Routine: ST_NUMBER_OF_LINES *) (* Purpose: To calculate the number of lines in a segment. *) (* Interface: SEG - Segment to be investigated. *) (* RETURNS - Number of lines contained by segment. *) (*********************************************************************) FUNCTION ST_NUMBER_OF_LINES; BEGIN WITH SEG DO BEGIN IF (FIRST >= 0) AND (LAST >= FIRST -1) THEN BEGIN ST_NUMBER_OF_LINES := LAST - FIRST + 1; END ELSE BEGIN WRITELN (OUTPUT, 'ST-NUMBER-OF-LINES: ', 'System Failure... Call maintenance.'); CLIP_STOP; END (*IF*); END (*WITH*); END (*ST_NUMBER_OF_LINES*); (*********************************************************************) (* Routine: ST_PUT_LINE *) (* Purpose: Add a source line to the last segment in the table. *) (* Interface: LINE - Source line to write. *) (* SEG - Segment to write to. *) (* ST vars: SEGMENT_TABLE. *) (*********************************************************************) PROCEDURE ST_PUT_LINE; BEGIN IF SEGMENT_TABLE.USED < ST_SIZE THEN BEGIN WITH SEGMENT_TABLE DO BEGIN (* Abort if the ST has become internally inconsistent. *) (* Othewise add line to the table. *) IF SEG.LAST <> USED THEN BEGIN WRITELN (OUTPUT, 'ST-PUT-LN: ', 'System Failure... Call maintenance.'); CLIP_STOP; END ELSE BEGIN USED := USED + 1; ST_WR (LINE, USED); SEG.LAST := USED; END (*IF*) END (*WITH*); END ELSE BEGIN (* Segment Table to small for this application. *) WRITELN (OUTPUT, 'ST-PUT-LN: ', 'Parameter Failure... Call maintenance.'); CLIP_STOP; END (*IF*); END (*ST_PUT_LINE*); (*********************************************************************) (* Routine: ST_PUT_SEG *) (* Purpose: Start a new segment in ST by writing its first line. *) (* Interface: LINE - The line to be written. *) (* SEG - The returned segment. *) (* ST vars: SEGMENT_TABLE, LAST_READ_SEG. *) (*********************************************************************) PROCEDURE ST_PUT_SEG; BEGIN IF SEGMENT_TABLE.USED < ST_SIZE THEN BEGIN WITH SEGMENT_TABLE DO BEGIN USED := USED + 1; ST_WR (LINE, USED); SEG.FIRST := USED; SEG.LAST := USED; END (*WITH*); END ELSE BEGIN WRITELN (OUTPUT, 'ST-PUT-SEG: ', 'Parameter Failure... Call maintenance.'); CLIP_STOP; END (*IF*); END (*ST_PUT_SEG*); (*********************************************************************) (* Routine: ST_FINIT - FINIsh Segment Table *) (* Purpose: Remove the segment-file from the directory. *) (* Interface: - *) (* ST vars: SEGMENT_TABLE. *) (*********************************************************************) PROCEDURE ST_FINIT; BEGIN END (*ST_REMOVE*); (*********************************************************************) (* Routine: ST_SEG_WIDTH - Segment Table SEGment USED. *) (* Purpose: Return the horizontal length of a segment. *) (* Interface: SEGMENT - Given segment. *) (* RETURNS - Length of the given segment. *) (* ST vars: SEGMENT_TABLE. *) (*********************************************************************) FUNCTION ST_SEG_WIDTH; VAR LINE: LINE_DES_; BEGIN ST_RD (LINE, SEG.FIRST); ST_SEG_WIDTH := FT_GET_LINE_LENGTH (LINE); END; (*********************************************************************) (* Routine: ST_WRITE_SEG *) (* Purpose: To write a segment to an output file. *) (* Interface: SEG - Segment to be written. *) (* BLANKS - Leading blanks for every line of the *) (* segment. *) (* DESTINATION - Indicates the destination of the *) (* writing action. *) (* REPORT_FILE - Report file for output. *) (*********************************************************************) PROCEDURE ST_WRITE_SEG; VAR K: ST_INDEX_; LINE: LINE_DES_; BEGIN IF SEG.FIRST >0 THEN FOR K := SEG.FIRST TO SEG.LAST DO BEGIN ST_RD (LINE, K); FT_WRLN (LINE, BLANKS, DESTINATION); END (*FOR*); END (*ST_WRITE_SEG*); (*----------- String Pool routines (ADT) -------------------------*) (*********************************************************************) (* Routine: SP_ADD_CHAR *) (* Purpose: Add character to currently written string. *) (* Interface: CH - Character to be added. *) (* STR - String to add character to. *) (*********************************************************************) PROCEDURE SP_ADD_CHAR; BEGIN WITH STRING_POOL^ DO IF USED < SP_SIZE THEN BEGIN (* SP has enough space left to accept another character. *) USED := USED + 1; CHARS[USED] := CH; IF STR.FIRST =0 THEN BEGIN (* First character of a new string. *) STR.FIRST := USED; STR.LAST := USED; END ELSE BEGIN (* The string already exists. Abort if this string is *) (* not physically the last one of the SP. *) IF STR.LAST <> USED - 1 THEN BEGIN WRITELN (OUTPUT, 'SP-ADD-CHAR: ', 'System Failure... Call maintenance.'); CLIP_STOP; END (*IF*); STR.LAST := USED; END (*IF*); END ELSE BEGIN WRITELN (OUTPUT, 'SP-ADD-CHAR: ', 'Parameter Failure... Call maintenance.'); CLIP_STOP; END (*IF.WITH*); END (*SP_ADD_CHAR*); (*********************************************************************) (* Routine: SP_CONC_STR *) (* Purpose: Concatenation of neighbouring strings. *) (* Interface: MASTER - Recieving string. *) (* SLAVE - Concatented string *) (*********************************************************************) PROCEDURE SP_CONC_STR; BEGIN IF MASTER.FIRST =0 THEN (* An empty MASTER becomes a SLAVE... *) MASTER := SLAVE ELSE IF SLAVE.FIRST =0 THEN (* but an empty SLAVE does not bother its MASTER. *) (* DO NOTHING... *) ELSE IF MASTER.FIRST <>0 THEN BEGIN (* Concatenate only if SLAVE follows MASTER immediately. *) IF MASTER.LAST + 1 = SLAVE.FIRST THEN MASTER.LAST := SLAVE.LAST ELSE BEGIN WRITELN (OUTPUT, 'SP-CONC-STR: ', 'System Failure... Call maintenance.'); CLIP_STOP; END (*IF*); END (*IF*); END (*SP_CONC_STR*); (*********************************************************************) (* Routine: SP_EQ *) (* Purpose: To decide if two strings are equal. *) (* Interface: STR1: First operand. *) (* STR2: Second operand. *) (* RETURNS: TRUE if both operands are equal. *) (* SP vars: STRING_POOL. *) (*********************************************************************) FUNCTION SP_EQ; VAR CONTINUE: BOOLEAN; INDEX: INTEGER; STR_L: INTEGER; BEGIN STR_L := SP_LENGTH_STR (STR1); IF STR_L <> SP_LENGTH_STR (STR2) THEN SP_EQ := FALSE ELSE BEGIN INDEX := 1; CONTINUE := TRUE; SP_EQ := TRUE; WHILE (CONTINUE) AND (INDEX <= STR_L) DO BEGIN IF SP_GET_CHAR (INDEX, STR1) <> SP_GET_CHAR (INDEX, STR2) THEN BEGIN CONTINUE := FALSE; SP_EQ := FALSE; END (*IF*); INDEX := INDEX + 1; END (*WHILE*); END (*IF*); END (*SP_EQ*); (*********************************************************************) (* Routine: SP_EXTR_STR *) (* Purpose: To extract a sequence of characters out of the SP *) (* and to store these characters in a packed array. *) (* Interface: STR - Descriptor of the wanted string. *) (* STR132 - The extracted characters. *) (*********************************************************************) PROCEDURE SP_EXTR_STR; VAR I: INTEGER; K: SP_INDEX_; BEGIN IF STR.FIRST= 0 THEN BEGIN STR132.LENGTH := 0; STR132.BODY := EMPTY_STRING_FIXED; END ELSE IF STR.LAST <= STRING_POOL^.USED THEN BEGIN STR132.BODY := EMPTY_STRING_FIXED; I := 0; FOR K := STR.FIRST TO STR.LAST DO BEGIN I := I + 1; STR132.BODY[I] := STRING_POOL^.CHARS[K]; END; STR132.LENGTH := I; END ELSE BEGIN WRITELN (OUTPUT, 'SP_EXTR_STR: ', 'System Failure... Call maintenance.'); CLIP_STOP; END (*IF.IF*); END; (*********************************************************************) (* Routine: SP_GET_CHAR *) (* Purpose: Get character from given position of a string. *) (* Interface: INDEX - Index of the wanted character. *) (* STR - String to be searched. *) (* RETURNS - Wanted character. *) (* SP vars: STRING_POOL. *) (* MOD1: EWvA (18/12/91) ivm probleem met SCAN_LINE (7). *) (*********************************************************************) FUNCTION SP_GET_CHAR; BEGIN WITH STR DO BEGIN (* Check if value of INDEX is within correct range. *) IF ((LAST - FIRST +1) < INDEX) OR (INDEX <= 0) THEN BEGIN (* MOD1: WRITELN (OUTPUT, 'SP-GET_CHAR: ', *) (* MOD1: 'System Failure... Call maintenance.'); *) (* MOD1: CLIP_STOP; *) SP_GET_CHAR := CHR(0); (* MOD1: *) END ELSE (* INDEX and STR are sound. Proceed to retrieve *) (* character. *) SP_GET_CHAR := STRING_POOL^.CHARS [FIRST + INDEX -1]; END (*IF*) END (*SP_GET_CHAR*); (*********************************************************************) (* Routine: SP_INIT *) (* Purpose: General initialization of the String Pool. It is *) (* only activated once at the start of an CLIP-run. *) (*********************************************************************) PROCEDURE SP_INIT; BEGIN NEW (STRING_POOL); STRING_POOL^.USED := 0; END (*SP_INIT*); (*********************************************************************) (* Routine: SP_INIT_STR *) (* Purpose: Initialize a string *) (* Interface: STR - the string to be initialized. *) (*********************************************************************) PROCEDURE SP_INIT_STR; BEGIN STR.FIRST := 0; STR.LAST := -1; END (*SP_INIT_STR*); (*********************************************************************) (* Routine: SP_IS_EMPTY_STR *) (* Purpose: The function examines if a string is empty or not. *) (* Interface: STR - string to be examined. *) (* RETURNS - TRUE if string is empty. *) (*********************************************************************) FUNCTION SP_IS_EMPTY_STR; BEGIN SP_IS_EMPTY_STR := (SP_LENGTH_STR(STR) = 0); END (*SP_IS_EMPTY_STR*); (*********************************************************************) (* Routine: SP_LENGTH_STR *) (* Purpose: To calculate the length of a string. *) (* Interface: STR: Given string. *) (* RESULT: Length of STRING. *) (*********************************************************************) FUNCTION SP_LENGTH_STR; BEGIN SP_LENGTH_STR := STR.LAST - STR.FIRST + 1; END (*SP_LENGTH_STR*); (*********************************************************************) (* Routine: SP_ADD_BUFFER *) (* Purpose: Add the buffer to a string. *) (* Interface: STR - String to which the buffer is added. *) (* SP vars: BUFFER *) (*********************************************************************) PROCEDURE SP_ADD_BUFFER; VAR I : INTEGER; BEGIN SP_INIT_STR (STR); FOR I := 1 TO BUFFER.LENGTH DO SP_ADD_CHAR (BUFFER.BODY[I], STR); END (*SP_ADD_BUFFER*); (*********************************************************************) (* Routine: SP_ADD_BUFFER_CHAR *) (* Purpose: Add a character to the buffer. *) (* Interface: CH - Character to be added. *) (* SP vars: BUFFER *) (*********************************************************************) PROCEDURE SP_ADD_BUFFER_CHAR; BEGIN WITH BUFFER DO IF LENGTH < 132 THEN BEGIN LENGTH := LENGTH + 1; BODY[LENGTH] := CH; END ELSE BEGIN WRITELN (OUTPUT,'SP_ADD_BUFFER_CHAR system failure...', 'Call maintenance'); CLIP_STOP; END (*IF*); END (*SP_ADD_BUFFER_CHAR*); (*********************************************************************) (* Routine: SP_GET_BUFFER_CHAR *) (* Purpose: Get a character from the buffer. *) (* Interface: INDEX - Index of the wanted character. *) (* SP_GET_BUFFER_CHAR - Character to get. *) (* SP vars: BUFFER *) (*********************************************************************) FUNCTION SP_GET_BUFFER_CHAR; BEGIN IF INDEX IN [1..BUFFER.LENGTH] THEN SP_GET_BUFFER_CHAR := BUFFER.BODY[INDEX] ELSE SP_GET_BUFFER_CHAR := CHR(0); END (*SP_GET_BUFFER_CHAR*); (*********************************************************************) (* Routine: SP_INIT_BUFFER *) (* Purpose: Initialize the buffer by making it empty. *) (* SP vars: BUFFER *) (*********************************************************************) PROCEDURE SP_INIT_BUFFER; BEGIN BUFFER.LENGTH := 0; END (*SP_INIT_BUFFER*); (*----------- DIAGNOSTic routines (ADT) --------------------------*) (*********************************************************************) (* Routine: DIAGNOST_INIT - INITialize the variables of DIAGNOST. *) (* Purpose: Initialize the global variables of procdure DIAG. *) (* Interface: - *) (* DIAGNOST vars: DIAG_TBL, NO_MESSAGES, NR_MSG. *) (*********************************************************************) PROCEDURE DIAGNOST_INIT; VAR K: INTEGER; TBL_FILE: TEXT; ERROR_CODE: INTEGER; DUMMY_ERROR: INTEGER; DUMMY_FILE_OK : BOOLEAN; DUMMY_ERROR_MSG : ERROR_MSG_; AUX_STRING_8: PACKED ARRAY[1..8] OF CHAR; TBL_FILE_NAME: FILE_SPEC_; MESS_CNT: INTEGER; CH : CHAR; BEGIN (******* DIAGNOST_INIT body *******) NO_MESSAGES := FALSE; NR_MSG := 0; FOR K := 1 TO MAX_NR_MESS DO DIAG_TBL[K].MESS_LOC := ' '; (* Clear the variable which is to hold the specification of the *) (* error message file. *) TBL_FILE_NAME.BODY := EMPTY_STRING_FIXED; TBL_FILE_NAME.LENGTH := 0; (******* DIAGNOST_INIT Add environment (TP) (#Opt) *******) (* Write name of message file to TBL_FLE_NAME. The length must *) (* be exactly 8 characters. *) AUX_STRING_8 := 'CLIP_MSG'; WITH TBL_FILE_NAME DO BEGIN FOR K := 1 TO 8 DO BODY[LENGTH+K] := AUX_STRING_8[K]; LENGTH := LENGTH + 8; END (* WITH *); (******* DIAGNOST_INIT Add extension (TP) (#Opt) *******) EXT_FILE_PREP (TBL_FILE, TBL_FILE_NAME, INSP_MODE, DUMMY_FILE_OK, ERROR_CODE, DUMMY_ERROR_MSG); IF ERROR_CODE <> 0 THEN BEGIN NO_MESSAGES := TRUE; WRITELN ('Error message file (logical name: CLIP_MSG) not found.'); WRITELN ('CLiP will continue without diagnostics'); WRITELN; END ELSE BEGIN NO_MESSAGES := FALSE; (********************* DIAGNOST_INIT (1) ***********************) (** Initialize DIAG_TBL by reading the TBL_FILE. **) MESS_CNT := 1; WHILE NOT EOF (TBL_FILE) DO BEGIN WITH DIAG_TBL[MESS_CNT] DO BEGIN (********************* DIAGNOST_INIT (1.1) *****************) (** Initialize DIAG_TBL[MESS_CNT].MESS_LOC. **) READ (TBL_FILE, CH); READ (TBL_FILE, CH); READ (TBL_FILE, CH); K := 1; WHILE CH <> ':' DO BEGIN MESS_LOC[K] := CH; READ (TBL_FILE, CH); K := K + 1; END (*WHILE*); (***************** End of DIAGNOST_INIT (1.1) **************) (********************* DIAGNOST_INIT (1.2) *****************) (** Initialize DIAG_TBL[MESS_CNT].MESSAGE. **) MESSAGE := EMPTY_STRING_FIXED; READ (TBL_FILE, CH); MESS_L := 1; WHILE CH <> '%' DO BEGIN IF EOLN (TBL_FILE) THEN READLN (TBL_FILE); READ (TBL_FILE, CH); IF CH <> '%' THEN BEGIN MESSAGE[MESS_L] := CH; MESS_L := MESS_L + 1; END (*IF*); END (*WHILE*); (***************** End of DIAGNOST_INIT (1.2) **************) READLN (TBL_FILE); END (*WITH*); MESS_CNT := MESS_CNT + 1; END (*WHILE*); (***************** End of DIAGNOST_INIT (1) ********************) (* Close the TBL_FILE and ignore any errors that may occur. *) EXT_FILE_CLOSE (TBL_FILE, DUMMY_ERROR); END (*IF*); (***************** End of DIAGNOST_INIT body *******************) END (*DIAGNOST_INIT*); (*********************************************************************) (* Routine: DIAG - Issue a DIAGnostic message. *) (* Purpose: Handling of all diagnostics by a message to the *) (* terminal. *) (* Interface: DIAG_TBL - Internal table with messages. *) (* MSG_TBL - Internal table with detected errors. *) (* NR_MSG - Counting error messages in MSG_TBL. *) (* SEV - Severity of the diagnostic. *) (* LOC - Program location which detected the *) (* problem. *) (* SOURCE_LINE - Source line causing the problem. *) (* SEGMENT - Segment causing the problem. *) (* STRING132 - Keyword(s) indicating the specific *) (* diagnostic. *) (*********************************************************************) PROCEDURE DIAG (SEV: SEV_CODE_; LOC: LOC_SPEC_; SOURCE_LINE: LINE_DES_; SEGMENT: SEGMENT_DES_; STRING132: STRING132_); VAR K : INTEGER; BEGIN (************************* DIAG (body) *****************************) IF NOT NO_MESSAGES THEN BEGIN IF NR_MSG < MAX_ERROR THEN BEGIN NR_MSG := NR_MSG + 1; (********************* DIAG (1) ************************) (** Store the actual parameters passed to DIAG in **) (** MSG_TBL[NR_MSG]. **) MSG_TBL[NR_MSG].SEV := SEV; MSG_TBL[NR_MSG].LOC := LOC; MSG_TBL[NR_MSG].STRING132 := STRING132; MSG_TBL[NR_MSG].SOURCE_LINE := SOURCE_LINE; MSG_TBL[NR_MSG].SEGMENT := SEGMENT; IF NOT ST_IS_EMPTY_SEG (SEGMENT) THEN MSG_TBL[NR_MSG].LINE_ABS := ST_ABS_SEG (SEGMENT) ELSE IF FT_GET_LINE_LENGTH (SOURCE_LINE) > 0 THEN MSG_TBL[NR_MSG].LINE_ABS := FT_ABS_LINE_NUMBER (SOURCE_LINE) ELSE BEGIN WRITELN ('Internal error DIAG (1)... Call maintenance'); WRITELN ('Troubles caused by an error detected by: '); FOR K := 1 TO LOC_SPEC_L DO WRITE (LOC[K]); NR_MSG := NR_MSG - 1; END (*IF.IF*); (******************* End of DIAG (1) *******************) END ELSE IF NR_MSG = MAX_ERROR THEN BEGIN WRITELN (OUTPUT, 'CLIP detected more then ', NR_MSG,' errors'); WRITELN (OUTPUT, 'Only first ', NR_MSG, ' diagnostic messages will be generated'); NR_MSG := NR_MSG + 1; END ELSE IF NR_MSG > MAX_ERROR THEN BEGIN (* Nothing remains to be done here. *) END (*IF.IF.IF*); END (*IF*); (********************* End of DIAG (body) **********************) END (*DIAG*); (*********************************************************************) (* Routine: DIAGNOST_EXIT - Exit the diagnostic table. *) (* Purpose: Generate the cumulated list of diagnostics to the *) (* termnal and, if specified, to a report file. *) (* Interface: DIAGNOST module variables *) (* REPORT_FILE - From CLIP_CDL *) (* REPORT_OK - From CLIP_CDL *) (* RUN_INFO variables *) (*********************************************************************) PROCEDURE DIAGNOST_EXIT; VAR I, K: INTEGER; MESS_INDEX: INTEGER; FILE_SPEC: FILE_SPEC_; FIRST, LAST: INTEGER; TMP_STRING_8: PACKED ARRAY [1..8] OF CHAR; J: INTEGER; BEGIN (********************* DIAGNOST_EXIT (body) ************************) IF NOT NO_MESSAGES THEN BEGIN IF NR_MSG > MAX_ERROR THEN NR_MSG := MAX_ERROR; (***************** DIAGNOST_EXIT (1) ***************************) (** Sort MSG_TBL by absolute line numbers. **) FOR K := NR_MSG DOWNTO 1 DO BEGIN FOR I := 1 TO K-1 DO BEGIN IF MSG_TBL[I].LINE_ABS > MSG_TBL[I+1].LINE_ABS THEN BEGIN MSG_TBL[MAX_ERROR+1] := MSG_TBL[I]; MSG_TBL[I] := MSG_TBL[I+1]; MSG_TBL[I+1] := MSG_TBL[MAX_ERROR+1]; END (*IF*); END (*FOR*); END (*FOR*); (***************** End of DIAGNOST_EXIT (1) ********************) (* Write the opening lines of the report(s). *) IF NR_MSG > 0 THEN BEGIN WRITELN (OUTPUT, '============================ ', 'Diagnostics ==============================='); IF REPORT_OK THEN WRITELN (REPORT_FILE, '============================ ', 'Diagnostics ==============================='); END (* IF *); (***************** DIAGNOST_EXIT (2) ***************************) (** Generate messages from MSG_TBL and DIAG_TBL to OUTPUT and **) (** also to REPORT_FILE if REPORT_OK is raised. Write a **) (** diagnostic in case of trouble, but do not abort. **) FOR K := 1 TO NR_MSG DO BEGIN MESS_INDEX := 0; (***************** DIAGNOST_EXIT (2.1) *************************) (** Search DIAG_TBL for MSG_TBL[K].LOC. Store the index in **) (** MESS_INDEX. **) FOR I := 1 TO MAX_NR_MESS DO BEGIN IF DIAG_TBL[I].MESS_LOC = MSG_TBL[K].LOC THEN MESS_INDEX := I; END (*FOR*); (**************** End of DIAGNOST_EXIT (2.1) *******************) IF MESS_INDEX = 0 THEN BEGIN WRITELN (OUTPUT, 'system error DIAGNOST_EXIT ..... call maintenance'); WRITELN ('Not able to generate diagnostic message.'); WRITE ('DIAGNOST_EXIT was called by : '); FOR I := 1 TO LOC_SPEC_L DO WRITE (MSG_TBL[K].LOC[I]); IF REPORT_OK THEN BEGIN WRITELN (REPORT_FILE, 'system error DIAGNOST_EXIT ..... call maintenance'); WRITELN (REPORT_FILE, 'Not able to generate diagnostic message.'); WRITE (REPORT_FILE, 'DIAGNOST_EXIT was called by : '); FOR I := 1 TO LOC_SPEC_L DO WRITE (REPORT_FILE, MSG_TBL[K].LOC[I]); END (* IF *); END ELSE BEGIN (***************** DIAGNOST_EXIT (2.2) *********************) (** Generate diagnostic using information stored in MSG_- **) (** TBL[K] and DIAG_TBL[MESS_INDEX]. **) WITH MSG_TBL[K] DO BEGIN CASE SEV OF WARN: TMP_STRING_8 := 'Warning '; ERR: TMP_STRING_8 := 'Error '; FAIL: TMP_STRING_8 := 'Failure '; DUMP: CLIP_STOP; END (*CASE*); WRITE (OUTPUT, TMP_STRING_8); IF REPORT_OK THEN WRITE (REPORT_FILE, TMP_STRING_8); IF NOT ST_IS_EMPTY_SEG (SEGMENT) THEN BEGIN ST_GET_SEG_RANGE (SEGMENT, FIRST, LAST); ST_GET_FILE_SPEC (SEGMENT, FILE_SPEC); WRITE (' between the lines ', FIRST:2, ' and ', LAST:2, ' of file: ' ); FOR I := 1 TO FILE_SPEC.LENGTH DO WRITE (FILE_SPEC.BODY[I]); WRITELN; WRITELN ('Source lines:'); WRITELN; (* Write segement to OUTPUT. *) ST_WRITE_SEG (SEGMENT, 0, 0); WRITELN; IF REPORT_OK THEN BEGIN WRITE (REPORT_FILE, ' between the lines ', FIRST:2, ' and ', LAST:2, ' of file: ' ); FOR I := 1 TO FILE_SPEC.LENGTH DO WRITE (REPORT_FILE, FILE_SPEC.BODY[I]); WRITELN (REPORT_FILE); WRITELN (REPORT_FILE, 'Source lines:'); WRITELN (REPORT_FILE); (* Write segement to file variable REPORT_FILE of FT *) (* (see also DIAGNOST_EXIT (2)). *) ST_WRITE_SEG (SEGMENT, 0, 3); WRITELN (REPORT_FILE); END (* IF *); END ELSE IF FT_GET_LINE_LENGTH (SOURCE_LINE) > 0 THEN BEGIN FT_GET_FILE_SPEC (SOURCE_LINE, FILE_SPEC); WRITE ('in line ', FT_GET_LINE_NUMBER (SOURCE_LINE):4); WRITE (' of file :'); FOR I := 1 TO FILE_SPEC.LENGTH DO WRITE (FILE_SPEC.BODY[I]); WRITELN; (* Write line to OUTPUT. *) FT_WRLN (SOURCE_LINE, 0, 0); IF REPORT_OK THEN BEGIN WRITE (REPORT_FILE, 'in line ', FT_GET_LINE_NUMBER (SOURCE_LINE):4); WRITE (REPORT_FILE, ' of file :'); FOR I := 1 TO FILE_SPEC.LENGTH DO WRITE (REPORT_FILE, FILE_SPEC.BODY[I]); WRITELN (REPORT_FILE); (* Write LINE to file variable REPORT_FILE of FT *) (* (see also DIAGNOST_EXIT (2)). *) FT_WRLN (SOURCE_LINE, 0, 3); END (* IF *); END ELSE BEGIN WRITELN ('Internal error DIAG... Call maintenance'); IF REPORT_OK THEN WRITELN (REPORT_FILE, 'Internal error DIAG... Call maintenance'); END (*IF.IF*); WITH DIAG_TBL[MESS_INDEX] DO BEGIN FOR I := 1 TO MESS_L DO BEGIN IF MESSAGE[I] <> '@' THEN BEGIN WRITE (MESSAGE[I]); IF REPORT_OK THEN WRITE (REPORT_FILE, MESSAGE[I]); END ELSE BEGIN FOR J := 1 TO STRING132.LENGTH DO BEGIN WRITE (STRING132.BODY[J]); IF REPORT_OK THEN WRITE (REPORT_FILE, STRING132.BODY[J]); END (*FOR*); END (*IF*); END (*FOR*); END(*WITH*); END (*WITH*); (**************** End of DIAGNOST_EXIT (2.2) ***************) END (*IF*); WRITELN; WRITELN; WRITELN ('------------------------------------', '------------------------------------'); IF REPORT_OK THEN BEGIN WRITELN (REPORT_FILE); WRITELN (REPORT_FILE); WRITELN (REPORT_FILE, '------------------------------------', '------------------------------------'); END (* IF *); END (*FOR*); (**************** End of DIAGNOST_EXIT (2) *********************) (* Write closing remarks of the report(s). Don't forget to close *) (* the REPORT_FILE if it has been used. Ignore closing problems. *) IF NR_MSG > 0 THEN BEGIN WRITE (OUTPUT, 'Diagnostics TOTAL of: ',NR_MSG:1); IF REPORT_OK THEN WRITE (REPORT_FILE, 'Diagnostics TOTAL of: ',NR_MSG:1); (* Print different text to distinguish between a for single *) (* error situation and a multiple error situation. *) IF NR_MSG = 1 THEN BEGIN WRITELN (' error or warning detected.'); IF REPORT_OK THEN WRITELN (REPORT_FILE, ' error or warning detected.'); END ELSE BEGIN WRITELN (' errors or warnings detected.'); IF REPORT_OK THEN WRITELN (REPORT_FILE, ' errors or warnings detected.'); END (* IF *); WRITELN; WRITELN ('============================ End of ', 'diagnostics ========================'); WRITELN; IF REPORT_OK THEN BEGIN WRITELN (REPORT_FILE); WRITELN (REPORT_FILE, '============================ End of ', 'diagnostics ========================'); WRITELN (REPORT_FILE); END (* IF *); END (*IF*); END (*IF*); (**************** End of DIAGNOST_EXIT (body) **********************) END (*DIAG*); (*----------- Main components of the CLiP system -----------------*) (*********************************************************************) (* Routine: SCN_LINE_INIT - INITialize variables of SCN_LINE. *) (* Purpose: Initialize the global variables of procedure SCAN_LINE.*) (* Interface: - *) (* SCN_LINE vars: ALLOWED *) (*********************************************************************) PROCEDURE SCN_LINE_INIT; BEGIN ALLOWED := ['A'..'Z', 'a'..'z', '0'..'9','.']; END; (*********************************************************************) (* Routine: SCAN_LINE - Scan a source line *) (* Purpose: To examine to what sort of CLIP category a source *) (* line belongs to. *) (* Interface: SOURCE_LINE: The line to be scanned. *) (* LINE_INFO: A record structure that holding all *) (* relevant info of this SOURCE_LINE. *) (* RUN_INFO: General information for this run. *) (*********************************************************************) PROCEDURE SCAN_LINE (VAR LINE_INFO: LINE_INFO_; VAR SOURCE_LINE: LINE_DES_; RUN_INFO: RUN_INFO_); VAR SCAN_LINE_CONTINUE: BOOLEAN; L2_LINE, L3_LINE, L4_LINE: BOOLEAN; LENGTH_LINE: INTEGER; START_INDEX, END_INDEX: INTEGER; SEGMENT: SEGMENT_DES_; STRING132: STRING132_; OPEN_FOUND, CLOSE_FOUND: BOOLEAN; X, Y: INTEGER; CH: CHAR; CLIP_CCL: CHAR; CLIP_CCR: CHAR; BEGIN (******* SCAN_LINE (body) *******) (************************* SCAN_LINE (1) ***************************) (** Initialize the Buffer and SCAN_LINE_CONTINUE. **) SP_INIT_BUFFER; SCAN_LINE_CONTINUE := TRUE; (********************* End of SCAN_LINE (1) ************************) (************************* SCAN_LINE (2) ***************************) (** Examine the length of SOURCE_LINE. Make SCAN_LINE_CONTINUE to **) (** FALSE if this length is shorter then that of CLIP_LPAR and **) (** CLIP_RPAR together and set LINE_INFO.CATEGORY to L5. **) WITH RUN_INFO DO BEGIN LENGTH_LINE := FT_GET_LINE_LENGTH (SOURCE_LINE); IF LENGTH_LINE < CLIP_LPAR.LENGTH+CLIP_RPAR.LENGTH THEN BEGIN LINE_INFO.CATEGORY := L5; SCAN_LINE_CONTINUE := FALSE; END (*IF*); END (*WITH*); (********************* End of SCAN_LINE (2) ************************) IF SCAN_LINE_CONTINUE THEN BEGIN (************************* SCAN_LINE (3) ***********************) (** Examine if SOURCE_LINE starts with an CLIP_LPAR and ends **) (** with an CLIP_RPAR. Set SCAN_LINE_CONTINUE to FALSE if this **) (** is not the case. Generate error message using SOURCE_LINE **) (** if only one of the two strings is detected. **) X := 1; OPEN_FOUND := TRUE; WITH RUN_INFO DO BEGIN WHILE (X <= CLIP_LPAR.LENGTH) AND (SCAN_LINE_CONTINUE) DO BEGIN CH := FT_GET_CHAR (SOURCE_LINE, X); IF CLIP_LPAR.BODY[X] <> CH THEN BEGIN SCAN_LINE_CONTINUE := FALSE; OPEN_FOUND := FALSE; END (*IF*); X := X+1; END (*WHILE*); X := LENGTH_LINE-CLIP_RPAR.LENGTH+1; Y := 1; CLOSE_FOUND := TRUE; WHILE (X <=LENGTH_LINE) DO BEGIN CH := FT_GET_CHAR (SOURCE_LINE, X); IF CLIP_RPAR.BODY[Y] <> CH THEN BEGIN CLOSE_FOUND := FALSE; SCAN_LINE_CONTINUE := FALSE; END (*IF*); X := X+1; Y := Y+1; END (*WHILE*); END (*WITH*); IF NOT SCAN_LINE_CONTINUE THEN BEGIN ST_INIT_SEG (SEGMENT); STRING132.LENGTH := 0; STRING132.BODY := EMPTY_STRING_FIXED; IF (OPEN_FOUND) AND (NOT CLOSE_FOUND) THEN DIAG (WARN, 'SCAN_LINE (3a) ', SOURCE_LINE, SEGMENT, STRING132) ELSE IF (CLOSE_FOUND) AND (NOT OPEN_FOUND) THEN DIAG (WARN, 'SCAN_LINE (3b) ', SOURCE_LINE, SEGMENT, STRING132); END (*WITH*); (********************* End of SCAN_LINE (3) ********************) IF NOT SCAN_LINE_CONTINUE THEN LINE_INFO.CATEGORY := L5 ELSE BEGIN L3_LINE := FALSE; (********************* SCAN_LINE (4) ***********************) (** Examine the character following CLIP_LPAR and the one **) (** preceeding CLIP_RPAR. Set L3_LINE to TRUE if at least **) (** one of these characters differs from CLIP_CC. Generate **) (** an error message using SOURCE_LINE if only one CLIP_CC **) (** is detected. **) WITH RUN_INFO DO BEGIN X := CLIP_LPAR.LENGTH+1; Y := LENGTH_LINE-CLIP_RPAR.LENGTH; CLIP_CCL := FT_GET_CHAR (SOURCE_LINE, X); CLIP_CCR := FT_GET_CHAR (SOURCE_LINE, Y); IF (CLIP_CCL <> CLIP_CC) AND (CLIP_CCR <> CLIP_CC) THEN BEGIN SCAN_LINE_CONTINUE := FALSE; L3_LINE := TRUE; END ELSE IF (CLIP_CCL<>CLIP_CC) AND (CLIP_CCR=CLIP_CC) THEN BEGIN ST_INIT_SEG (SEGMENT); STRING132.LENGTH := 0; STRING132.BODY := EMPTY_STRING_FIXED; DIAG (WARN, 'SCAN_LINE (4a) ', SOURCE_LINE, SEGMENT, STRING132); SCAN_LINE_CONTINUE := FALSE; L3_LINE := TRUE; END ELSE IF (CLIP_CCL = CLIP_CC) AND (CLIP_CCR <> CLIP_CC) THEN BEGIN ST_INIT_SEG (SEGMENT); STRING132.LENGTH := 0; STRING132.BODY := EMPTY_STRING_FIXED; DIAG (WARN, 'SCAN_LINE (4b) ', SOURCE_LINE, SEGMENT, STRING132); SCAN_LINE_CONTINUE := FALSE; L3_LINE := TRUE; END (*IF.IF.IF*); END (*WITH*); (***************** End of SCAN_LINE (4) ********************) IF (L3_LINE) AND (LINE_INFO.OPTIONS) THEN BEGIN (* SOURCE_LINE holds only options which will be *) (* scanned in a later stadium. Nothing remains to *) (* be done here. *) END ELSE BEGIN WITH RUN_INFO DO BEGIN START_INDEX := CLIP_LPAR.LENGTH; END_INDEX := SOURCE_LINE.USED-RUN_INFO.CLIP_RPAR.LENGTH; END (*WITH*); L4_LINE := TRUE; (********************* SCAN_LINE (5) *******************) (** Examine the characters in SOURCE_LINE starting at **) (** START_INDEX until a character not equal to CLIP_CC **) (** or until END_INDEX is reached. If such a character **) (** is detected, set L4_LINE to FALSE and store its **) (** position in START_INDEX. **) WHILE (START_INDEX < END_INDEX) AND (L4_LINE) DO BEGIN CH := FT_GET_CHAR (SOURCE_LINE, START_INDEX); IF CH <> RUN_INFO.CLIP_CC THEN L4_LINE := FALSE ELSE START_INDEX := START_INDEX+1; END (*WHILE*); (***************** End of SCAN_LINE (5) ****************) IF NOT L4_LINE THEN BEGIN IF NOT L3_LINE THEN LINE_INFO.OPTIONS := FALSE; X := START_INDEX; WHILE (X <= END_INDEX) AND (NOT LINE_INFO.OPTIONS) DO BEGIN CH := FT_GET_CHAR (SOURCE_LINE, X); IF (CH IN ALLOWED) OR (CH=RUN_INFO.OPTION_MARKER) THEN BEGIN IF CH=RUN_INFO.OPTION_MARKER THEN BEGIN LINE_INFO.OPTIONS := TRUE; SOURCE_LINE.POS_OPTION_MARKER := X; END ELSE BEGIN (************* SCAN_LINE (6) ***********) (** Add CH to the Buffer String. **) SP_ADD_BUFFER_CHAR (UC (CH)); (********* End of SCAN_LINE (6) ********) END (*IF*); END (*IF*); X := X+1; END (*WHILE*); L2_LINE := TRUE; (***************** SCAN_LINE (7) *******************) (** Check if the first LENGTH (CLIP_END) chars of **) (** the Bufffer String are equal to CLIP_END. If **) (** not, set L2_LINE to FALSE. **) WITH RUN_INFO DO BEGIN X := 1; WHILE (X <= CLIP_END.LENGTH) AND (SCAN_LINE_CONTINUE) DO BEGIN CH := SP_GET_BUFFER_CHAR (X); IF UC (CLIP_END.BODY[X]) <> UC (CH) THEN L2_LINE := FALSE; X := X+1; END (*WHILE*); END (*WITH*); (*************** End of SCAN_LINE (7) **************) END (*IF*); END (*IF*); IF L4_LINE THEN LINE_INFO.CATEGORY := L4 ELSE IF L3_LINE THEN LINE_INFO.CATEGORY := L3 ELSE IF L2_LINE THEN LINE_INFO.CATEGORY := L2 ELSE LINE_INFO.CATEGORY := L1; END (*IF*); END (*IF*); (********************* End of SCAN_LINE (body) *****************) END (*PROCEDURE SCAN_LINE*); (********************************************************************) (* Routine: CONVERT_OPTION *) (* Purpose: Covert an abbreviated option to its full length. *) (* Interface: OPTION: Option to be converted. *) (* ERROR_CODE: 0 - No Problems. *) (* 1 - No Match found. *) (* -1 - More then one match found. *) (********************************************************************) PROCEDURE CONVERT_OPTION (VAR OPTION: OPTION_KEYWORD_; VAR ERROR_CODE: ERROR_CODE_); VAR K, I: INTEGER; LENGTH_OPTION: INTEGER; LOCATED: BOOLEAN; DUMMY: OPTION_KEYWORD_; NR_MATCH: INTEGER; BEGIN DUMMY := EMPTY_OPTION; K := 1; NR_MATCH := 0; WHILE OPTION[K] <> ' ' DO K := K + 1; LENGTH_OPTION := K-1; LOCATED := FALSE; I := 1; ERROR_CODE := 1; (* Assume no match found. *) WHILE (I <= MAX_OPTIONS) DO BEGIN K := 1; LOCATED := TRUE; WHILE (K <= LENGTH_OPTION) AND (LOCATED) DO BEGIN IF UC (OPTION[K]) = UC (OPTION_TABLE[I,K]) THEN LOCATED := TRUE ELSE LOCATED := FALSE; K := K + 1; END (*WHILE*); IF LOCATED THEN BEGIN IF NR_MATCH = 0 THEN BEGIN ERROR_CODE := 0; (* One match has been found. *) DUMMY := OPTION_TABLE[I]; NR_MATCH := NR_MATCH + 1; END ELSE ERROR_CODE := -1; (* More then one match found *) END (*IF*); I := I + 1; END (*WHILE*); IF ERROR_CODE = 0 THEN OPTION := DUMMY; END (*CONVERT_OPTION*); (*********************************************************************) (* Routine: SCN_OPTS_INIT - INITialize the variables of SCN_OPTS. *) (* Purpose: Initialize the global variables of SCAN_OPTIONS. *) (* Interface: - *) (* SCN_OPTS vars: OPT_SPACE, DEFAULT_OPTIONS, OPT_CHARS, *) (* PASCAL_STRING, C_STRING. *) (*********************************************************************) PROCEDURE SCN_OPTS_INIT; BEGIN OPTION_TABLE [ 1] := 'QUICK '; OPTION_TABLE [ 2] := 'MULTIPLE '; OPTION_TABLE [ 3] := 'OPTIONAL '; OPTION_TABLE [ 4] := 'FILE '; OPTION_TABLE [ 5] := 'INDENT '; OPTION_TABLE [ 6] := 'COMMENT '; OPTION_TABLE [ 7] := 'OVERRULE '; OPTION_TABLE [ 8] := 'LEADER '; OPTION_TABLE [ 9] := 'TRAILER '; OPTION_TABLE [10] := 'SEPARATOR '; OPTION_TABLE [11] := 'DEFAULT '; OPTION_TABLE [12] := 'LINENUMBER '; OPT_CHARS := ['A'..'Z', 'a'..'z', '0'..'9', '"']; WITH DEFAULT_OPTIONS DO BEGIN QUICK := FALSE; MULTIPLE := FALSE; OPTIONAL := FALSE; OVERRULE := FALSE; LEADER := FALSE; DEFAULT := FALSE; TRAILER := FALSE; SEPARATOR := FALSE; LINENUMBER := FALSE; SP_INIT_STR (FILE_NAME); SP_INIT_STR (INDENT); SP_INIT_STR (COMMENT); END; PASCAL_STRING := EMPTY_STRING_FIXED; PASCAL_STRING[1] := 'P'; PASCAL_STRING[2] := 'A'; PASCAL_STRING[3] := 'S'; PASCAL_STRING[4] := 'C'; PASCAL_STRING[5] := 'A'; PASCAL_STRING[6] := 'L'; FORTRAN_STRING := EMPTY_STRING_FIXED; FORTRAN_STRING[1] := 'F'; FORTRAN_STRING[2] := 'O'; FORTRAN_STRING[3] := 'R'; FORTRAN_STRING[4] := 'T'; FORTRAN_STRING[5] := 'R'; FORTRAN_STRING[6] := 'A'; FORTRAN_STRING[7] := 'N'; C_STRING := EMPTY_STRING_FIXED; C_STRING[1] := 'C'; END; (*********************************************************************) (* Routine: SCAN_OPTIONS - SCAN OPTIONS *) (* Purpose: To scan and store the options that are specified by *) (* a stub or slot segment. *) (* Interface: SEGMENT_OPTIONS - The structure with options. *) (* SEGMENT - The segment to be scanned. *) (* RUN_INFO - The information for this run. *) (* SEGMENT_TYPE - Type of segment to be scanned. *) (*********************************************************************) PROCEDURE SCAN_OPTIONS (VAR SEGMENT_OPTIONS: OPTIONS_; SEGMENT: SEGMENT_DES_; RUN_INFO: RUN_INFO_; SEGMENT_TYPE: SEGMENT_TYPE_); VAR OPTION_KEYWORD: OPTION_KEYWORD_; LINE: LINE_DES_; SEGMENT_EXHAUSTED: BOOLEAN; INDEX: INTEGER; CH: CHAR; LENGTH_LINE: INTEGER; OK: BOOLEAN; STRING132: STRING132_; I: INTEGER; ERROR_CODE: ERROR_CODE_; DUMMY_LINE: LINE_DES_; AUX_STRING10: PACKED ARRAY[1..10] OF CHAR; BEGIN (******* SCAN_OPTIONS (body) *******) (************************* SCAN_OPTIONS (1) ********************) (** Initialize OPTION_KEYWORD. Make SEGMENT_OPTIONS equal to **) (** DEFAULT_OPTIONS and set SEGMENT_EXHAUSTED to FALSE. **) OPTION_KEYWORD := EMPTY_OPTION; SEGMENT_OPTIONS := DEFAULT_OPTIONS; SEGMENT_EXHAUSTED := FALSE; (********************* End of SCAN_OPTIONS (1) *****************) IF NOT ST_IS_EMPTY_SEG (SEGMENT) THEN BEGIN (********************* SCAN_OPTIONS (2) ********************) (** Retrieve first line from SEGMENT which holds an option **) (** marker and store it in LINE. Set SEGMENT_EXHAUSTED to **) (** TRUE if no such LINE could be found. **) ST_GET_OPTION_LINE (SEGMENT, LINE); IF LINE.ID =0 THEN SEGMENT_EXHAUSTED := TRUE; (***************** End of SCAN_OPTIONS (2) *****************) WHILE NOT SEGMENT_EXHAUSTED DO BEGIN (********************* SCAN_OPTIONS (3) ****************) (** Scan LINE for options with their arguments and put **) (** the result in SEGMENT_OPTIONS. Generate diagnostic **) (** message using SEGMENT in case of trouble. **) INDEX := FT_GET_POS_OPTION_MARKER (LINE); IF INDEX = 0 THEN INDEX := RUN_INFO.CLIP_LPAR.LENGTH + 1; LENGTH_LINE := FT_GET_LINE_LENGTH (LINE) - RUN_INFO.CLIP_RPAR.LENGTH; CH := FT_GET_CHAR (LINE, INDEX); WHILE INDEX < LENGTH_LINE DO BEGIN WHILE (CH <> RUN_INFO.OPTION_MARKER) AND (NOT (CH IN OPT_CHARS)) AND (INDEX < LENGTH_LINE) DO BEGIN INDEX := INDEX + 1; CH := FT_GET_CHAR (LINE, INDEX); END (*WHILE*); IF CH = RUN_INFO.OPTION_MARKER THEN BEGIN (********************* SCAN_OPTIONS (3.1) ******************) (** Start of a new option in LINE. Check by an empty **) (** OPTION_KEYWORD if previous option is "closed" correctly **) (** and issue a diagnostic if not. Read the characters **) (** following OPTION_MARKER until the next OPT_SPACE and **) (** store them in OPTION_KEYWORD. Read a possible argument **) (** and update SEGMENT_OPTIONS. Initialize OPTION_KEYWORD **) (** if all went well. **) IF OPTION_KEYWORD <> EMPTY_OPTION THEN BEGIN (********************* SCAN_OPTIONS (3.1.1) ********************) (** Missing argument of option stored in OPTION_KEYWORD. **) (** Generate a diagnostic using OPTION_KEYWORD and SEGMENT. **) STRING132.LENGTH := 0; STRING132.BODY := EMPTY_STRING_FIXED; FOR I := 1 TO MAX_OPTION_LENGTH DO BEGIN IF OPTION_KEYWORD[I] <> ' ' THEN BEGIN STRING132.BODY[I] := OPTION_KEYWORD[I]; STRING132.LENGTH := STRING132.LENGTH + 1; END (*IF*); END (*FOR*); DIAG (ERR, 'SCAN_OPTIONS (3.1.1) ', DUMMY_LINE, SEGMENT, STRING132); OPTION_KEYWORD := EMPTY_OPTION; (***************** End of SCAN_OPTIONS (3.1.1) *****************) END (*IF*); OK := FALSE; (********************* SCAN_OPTIONS (3.1.2) ************************) (** Store all characters following this OPTION_MARKER in OPTION_- **) (** KEYWORD until the first character that is not a member of **) (** OPT_CHARS. Try to located the option in OPTION_TABLE and make **) (** OK equal to TRUE if a match is found and store the full option **) (** in OPTION_KEYWORD. In case no match can be found generate a **) (** diagnostic message and jump to the next option marker. **) INDEX := INDEX + 1; CH := FT_GET_CHAR (LINE, INDEX); WHILE NOT (CH IN OPT_CHARS) AND (CH <> RUN_INFO.OPTION_MARKER) AND (INDEX < LENGTH_LINE) DO BEGIN INDEX := INDEX + 1; CH := FT_GET_CHAR (LINE, INDEX); END (*WHILE*); I := 1; WHILE CH IN OPT_CHARS DO BEGIN OPTION_KEYWORD [I] := CH; I := I + 1; INDEX := INDEX + 1; CH := FT_GET_CHAR (LINE, INDEX); END (*WHILE*); CONVERT_OPTION (OPTION_KEYWORD, ERROR_CODE); IF ERROR_CODE <> 0 THEN BEGIN STRING132.LENGTH := 0; STRING132.BODY := EMPTY_STRING_FIXED; FOR I := 1 TO MAX_OPTION_LENGTH DO BEGIN IF OPTION_KEYWORD[I] <> ' ' THEN BEGIN STRING132.BODY[I] := OPTION_KEYWORD[I]; STRING132.LENGTH := STRING132.LENGTH + 1; END (*IF*); END (*FOR*); IF ERROR_CODE = -1 THEN BEGIN (* More then one match found in table. *) DIAG (ERR, 'SCAN_OPTIONS (3.1.2)a ', DUMMY_LINE, SEGMENT, STRING132); OPTION_KEYWORD := EMPTY_OPTION; END ELSE IF ERROR_CODE = 1 THEN BEGIN (* No match found in the table. *) DIAG (ERR, 'SCAN_OPTIONS (3.1.2)b ', DUMMY_LINE, SEGMENT, STRING132); OPTION_KEYWORD := EMPTY_OPTION; END (*IF.IF*); (* Jump to the next OPTION_MARKER in LINE. *) WHILE (CH <> RUN_INFO.OPTION_MARKER) AND (INDEX<LENGTH_LINE) DO BEGIN INDEX := INDEX + 1; CH := FT_GET_CHAR (LINE, INDEX); END (*WHILE*); END ELSE OK := TRUE; (********************* End of SCAN_OPTIONS (3.1.2) *****************) IF OK THEN BEGIN IF OPTION_KEYWORD = OPTION_TABLE[1] THEN BEGIN SEGMENT_OPTIONS.QUICK := TRUE; OPTION_KEYWORD := EMPTY_OPTION; END ELSE IF OPTION_KEYWORD = OPTION_TABLE[2] THEN BEGIN SEGMENT_OPTIONS.MULTIPLE := TRUE; OPTION_KEYWORD := EMPTY_OPTION; END ELSE IF OPTION_KEYWORD = OPTION_TABLE[3] THEN BEGIN SEGMENT_OPTIONS.OPTIONAL := TRUE; OPTION_KEYWORD := EMPTY_OPTION; END ELSE IF OPTION_KEYWORD = OPTION_TABLE[4] THEN BEGIN (***************** SCAN_OPTIONS (3.1.3) ********************) (** Add all characters from INDEX until the next member of **) (** OPT_SPACE to the string SEGMENT_OPTIONS.FILE_NAME. **) (** Generate a diagnostic message in case of trouble. **) WHILE (NOT (CH IN OPT_CHARS)) AND (CH <> '"') AND (INDEX<LENGTH_LINE) DO BEGIN INDEX := INDEX + 1; CH := FT_GET_CHAR (LINE, INDEX); END (*WHILE*); IF CH = '"' THEN BEGIN INDEX := INDEX + 1; CH := FT_GET_CHAR (LINE, INDEX); WHILE (CH <> '"') AND (INDEX < LENGTH_LINE) DO BEGIN (* SP_ADD_CHAR (UC (CH), SEGMENT_OPTIONS.FILE_NAME); 14/10/93) *) SP_ADD_CHAR (CH, SEGMENT_OPTIONS.FILE_NAME); INDEX := INDEX + 1; CH := FT_GET_CHAR (LINE, INDEX); END (*WHILE*); IF CH = '"' THEN BEGIN INDEX := INDEX + 1; CH := FT_GET_CHAR (LINE, INDEX); END ELSE BEGIN SP_EXTR_STR (SEGMENT_OPTIONS.FILE_NAME, STRING132); DIAG (ERR, 'SCAN_OPTIONS (3.1.3)a ', DUMMY_LINE, SEGMENT, STRING132); SP_INIT_STR (SEGMENT_OPTIONS.FILE_NAME); OPTION_KEYWORD := EMPTY_OPTION; END (*IF*); END ELSE IF (CH IN OPT_CHARS) THEN BEGIN SP_EXTR_STR (SEGMENT_OPTIONS.FILE_NAME, STRING132); DIAG (ERR, 'SCAN_OPTIONS (3.1.3)b ', DUMMY_LINE, SEGMENT, STRING132); SP_INIT_STR (SEGMENT_OPTIONS.FILE_NAME); OPTION_KEYWORD := EMPTY_OPTION; (* Jump to the next option marker. *) WHILE (CH <> RUN_INFO.OPTION_MARKER) AND (INDEX<LENGTH_LINE) DO BEGIN INDEX := INDEX + 1; CH := FT_GET_CHAR (LINE, INDEX); END (*WHILE*); END ELSE IF INDEX = LENGTH_LINE THEN BEGIN (* The file specification must be on the next line. *) (* Nothing remains to be done here. *) END (* IF.IF.IF*); (***************** End of SCAN_OPTIONS (3.1.3) *************) IF NOT SP_IS_EMPTY_STR (SEGMENT_OPTIONS.FILE_NAME) THEN OPTION_KEYWORD := EMPTY_OPTION; END ELSE IF OPTION_KEYWORD = OPTION_TABLE[5] THEN BEGIN (***************** SCAN_OPTIONS (3.1.4) ********************) (** Add all characters from INDEX until the next member of **) (** OPT_SPACE to the string SEGMENT_OPTIONS.INDENT. Give an **) (** error and initialize SEGMENT_OPTIONS.INDENT and **) (** OPTION_KEYWORD and in case of trouble. **) WHILE (NOT (CH IN OPT_CHARS)) AND (INDEX < LENGTH_LINE) AND (CH <> RUN_INFO.OPTION_MARKER) DO BEGIN INDEX := INDEX + 1; CH := FT_GET_CHAR (LINE, INDEX); END (*WHILE*); WHILE (CH IN OPT_CHARS) AND (INDEX < LENGTH_LINE) DO BEGIN SP_ADD_CHAR (UC (CH), SEGMENT_OPTIONS.INDENT); INDEX := INDEX + 1; CH := FT_GET_CHAR (LINE, INDEX); END (*WHILE*); IF NOT SP_IS_EMPTY_STR (SEGMENT_OPTIONS.INDENT) THEN BEGIN SP_EXTR_STR (SEGMENT_OPTIONS.INDENT, STRING132); IF ((STRING132.BODY[1] <> 'O') OR (STRING132.BODY[2] <> 'N')) AND ((STRING132.BODY[1] <> 'O') OR (STRING132.BODY[2] <> 'F') OR (STRING132.BODY[3] <> 'F')) THEN BEGIN SP_INIT_STR (SEGMENT_OPTIONS.INDENT); OPTION_KEYWORD := EMPTY_OPTION; DIAG (ERR, 'SCAN_OPTIONS (3.1.4) ', DUMMY_LINE, SEGMENT, STRING132); END (*IF*); END ELSE BEGIN (* The argument of the INDENT-option must be on the next *) (* line. Nothing remains to be done here. *) END (*IF*); (************* End of SCAN_OPTIONS (3.1.4) *****************) IF NOT SP_IS_EMPTY_STR (SEGMENT_OPTIONS.INDENT) THEN OPTION_KEYWORD := EMPTY_OPTION; END ELSE IF OPTION_KEYWORD = OPTION_TABLE[6] THEN BEGIN (***************** SCAN_OPTIONS (3.1.5) ********************) (** Add all characters from INDEX until the next member of **) (** OPT_SPACE to SEGMENT_OPTIONS.COMMENT. Issue diagnostic **) (** and initialize OPTION_KEYWORD and SEGMENT_OPTIONS.- **) (** COMMENT in case of trouble. **) WHILE (NOT (CH IN OPT_CHARS)) AND (INDEX < LENGTH_LINE) AND (CH <> RUN_INFO.OPTION_MARKER) DO BEGIN INDEX := INDEX + 1; CH := FT_GET_CHAR (LINE, INDEX); END (*WHILE*); WHILE (CH IN OPT_CHARS) AND (INDEX < LENGTH_LINE) DO BEGIN SP_ADD_CHAR (UC (CH), SEGMENT_OPTIONS.COMMENT); INDEX := INDEX + 1; CH := FT_GET_CHAR (LINE, INDEX); END (*WHILE*); IF NOT SP_IS_EMPTY_STR (SEGMENT_OPTIONS.COMMENT) THEN BEGIN SP_EXTR_STR (SEGMENT_OPTIONS.COMMENT, STRING132); IF (STRING132.BODY = PASCAL_STRING) OR (STRING132.BODY = FORTRAN_STRING) OR (STRING132.BODY = C_STRING) THEN BEGIN DIAG (WARN, 'SCAN_OPTIONS (3.1.5)a ', DUMMY_LINE, SEGMENT, STRING132); SP_INIT_STR (SEGMENT_OPTIONS.COMMENT); OPTION_KEYWORD := EMPTY_OPTION; END ELSE IF ((STRING132.BODY[1] <> 'O') OR (STRING132.BODY[2] <> 'N')) AND ((STRING132.BODY[1] <> 'O') OR (STRING132.BODY[2] <> 'F') OR (STRING132.BODY[3] <> 'F')) THEN BEGIN DIAG (ERR, 'SCAN_OPTIONS (3.1.5)b ', DUMMY_LINE, SEGMENT, STRING132); SP_INIT_STR (SEGMENT_OPTIONS.COMMENT); OPTION_KEYWORD := EMPTY_OPTION; END (*IF.IF*); END ELSE BEGIN (* The argument of the option COMMENT must be on the *) (* next line. Nothing remains to be done here *) END (*IF*); (************* End of SCAN_OPTIONS (3.1.5) *****************) IF NOT SP_IS_EMPTY_STR (SEGMENT_OPTIONS.COMMENT) THEN OPTION_KEYWORD := EMPTY_OPTION; END ELSE IF OPTION_KEYWORD = OPTION_TABLE[7] THEN BEGIN SEGMENT_OPTIONS.OVERRULE := TRUE; OPTION_KEYWORD := EMPTY_OPTION; END ELSE IF OPTION_KEYWORD = OPTION_TABLE[8] THEN BEGIN SEGMENT_OPTIONS.LEADER := TRUE; OPTION_KEYWORD := EMPTY_OPTION; END ELSE IF OPTION_KEYWORD = OPTION_TABLE[9] THEN BEGIN SEGMENT_OPTIONS.TRAILER := TRUE; OPTION_KEYWORD := EMPTY_OPTION; END ELSE IF OPTION_KEYWORD = OPTION_TABLE[10] THEN BEGIN SEGMENT_OPTIONS.SEPARATOR := TRUE; OPTION_KEYWORD := EMPTY_OPTION; END ELSE IF OPTION_KEYWORD = OPTION_TABLE[11] THEN BEGIN SEGMENT_OPTIONS.DEFAULT := TRUE; OPTION_KEYWORD := EMPTY_OPTION; END ELSE IF OPTION_KEYWORD = OPTION_TABLE[12] THEN BEGIN SEGMENT_OPTIONS.LINENUMBER := TRUE; OPTION_KEYWORD := EMPTY_OPTION; END (*IF.IF.IF.IF.IF.IF.IF.IF.IF.IF.IF.IF*); END (*IF*); (***************** End of SCAN_OPTIONS (3.1) ***************) END ELSE IF CH IN OPT_CHARS THEN BEGIN (********************* SCAN_OPTIONS (3.2) ******************) (** CH is only legal at this point as the first character **) (** of the argument of the previous option, i.e. **) (** OPTION_KEYWORD must not be empty. Read this argument. **) (** When problems arise, jump to next OPTION_MARKER and **) (** issue a diagnostic message. **) IF OPTION_KEYWORD <> EMPTY_OPTION THEN BEGIN IF OPTION_KEYWORD = OPTION_TABLE[4] THEN BEGIN (***************** SCAN_OPTIONS (3.2.1) ********************) (** Add characters from INDEX to SEGMENT_OPTIONS.FILE_NAME **) (** until the next OPT_SPACE is met. Diagnostic in case of **) (** trouble. **) WHILE (NOT (CH IN OPT_CHARS)) AND (CH <> '"') AND (INDEX < LENGTH_LINE) DO BEGIN INDEX := INDEX + 1; CH := FT_GET_CHAR (LINE, INDEX); END (*WHILE*); IF CH = '"' THEN BEGIN INDEX := INDEX + 1; CH := FT_GET_CHAR (LINE, INDEX); WHILE (CH <> '"') AND (INDEX <= LENGTH_LINE) DO BEGIN (* SP_ADD_CHAR (UC (CH), SEGMENT_OPTIONS.FILE_NAME); 14/10/93 *) SP_ADD_CHAR (CH, SEGMENT_OPTIONS.FILE_NAME); INDEX := INDEX + 1; CH := FT_GET_CHAR (LINE, INDEX); END (*WHILE*); IF CH='"' THEN BEGIN INDEX := INDEX + 1; CH := FT_GET_CHAR (LINE, INDEX); END ELSE BEGIN SP_EXTR_STR (SEGMENT_OPTIONS.FILE_NAME, STRING132); DIAG (ERR, 'SCAN_OPTIONS (3.2.1)a ', DUMMY_LINE, SEGMENT, STRING132); SP_INIT_STR (SEGMENT_OPTIONS.FILE_NAME); OPTION_KEYWORD := EMPTY_OPTION; END (*IF*); END ELSE IF (CH IN OPT_CHARS) THEN BEGIN SP_EXTR_STR (SEGMENT_OPTIONS.FILE_NAME, STRING132); DIAG (ERR, 'SCAN_OPTIONS (3.2.1)b ', DUMMY_LINE, SEGMENT, STRING132); SP_INIT_STR (SEGMENT_OPTIONS.FILE_NAME); OPTION_KEYWORD := EMPTY_OPTION; (* Jump to the next option marker. *) WHILE (CH <> RUN_INFO.OPTION_MARKER) AND (INDEX<LENGTH_LINE) DO BEGIN INDEX := INDEX + 1; CH := FT_GET_CHAR (LINE, INDEX); END (*WHILE*); END ELSE IF INDEX=LENGTH_LINE THEN BEGIN (* The file specification must be on the next line. *) (* Nothing remains to be done here. *) END (*IF.IF.IF*); (************* End of SCAN_OPTIONS (3.2.1) *****************) IF NOT SP_IS_EMPTY_STR (SEGMENT_OPTIONS.FILE_NAME) THEN OPTION_KEYWORD := EMPTY_OPTION; END ELSE IF OPTION_KEYWORD=OPTION_TABLE[5] THEN BEGIN (***************** SCAN_OPTIONS (3.2.2) ********************) (** Add characters from INDEX to SEGMENT_OPTIONS.INDENT **) (** until the next OPT_SPACE is met. Generate a diagnostic **) (** message and reset OPTION_KEYWORD and SEGMENT_OPTIONS.- **) (** INDENT in case of trouble. **) WHILE (NOT (CH IN OPT_CHARS)) AND (INDEX < LENGTH_LINE) DO BEGIN INDEX := INDEX + 1; CH := FT_GET_CHAR (LINE, INDEX); END (*WHILE*); WHILE (CH IN OPT_CHARS) AND (INDEX<LENGTH_LINE) DO BEGIN SP_ADD_CHAR (UC (CH), SEGMENT_OPTIONS.INDENT); INDEX := INDEX + 1; CH := FT_GET_CHAR (LINE, INDEX); END (*WHILE*); IF NOT SP_IS_EMPTY_STR (SEGMENT_OPTIONS.INDENT) THEN BEGIN SP_EXTR_STR (SEGMENT_OPTIONS.INDENT, STRING132); IF ((STRING132.BODY[1] <> 'O') OR (STRING132.BODY[2] <> 'N')) AND ((STRING132.BODY[1] <> 'O') OR (STRING132.BODY[2] <> 'F') OR (STRING132.BODY[3] <> 'F')) THEN BEGIN SP_INIT_STR (SEGMENT_OPTIONS.INDENT); OPTION_KEYWORD := EMPTY_OPTION; DIAG (ERR, 'SCAN_OPTIONS (3.2.2) ', DUMMY_LINE, SEGMENT, STRING132); END (*IF*); END ELSE BEGIN (* The argument of the option INDENT must be on the next *) (* line. Nothing remains to be done here *) END (*IF*); (************* End of SCAN_OPTIONS (3.2.2) *****************) IF NOT SP_IS_EMPTY_STR (SEGMENT_OPTIONS.INDENT) THEN OPTION_KEYWORD := EMPTY_OPTION; END ELSE IF OPTION_KEYWORD=OPTION_TABLE[6] THEN BEGIN (***************** SCAN_OPTIONS (3.2.3) ********************) (** Add characters from INDEX to SEGMENT_OPTIONS.COMMENT **) (** until the next OPT_SPACE is met. Generate a diagnostic **) (** message and reset OPTION_KEYWORD and SEGMENT_OPTIONS.- **) (** COMMENT in case of trouble. **) WHILE (NOT (CH IN OPT_CHARS)) AND (INDEX<LENGTH_LINE) DO BEGIN INDEX := INDEX + 1; CH := FT_GET_CHAR (LINE, INDEX); END (*WHILE*); WHILE (CH IN OPT_CHARS) AND (INDEX<LENGTH_LINE) DO BEGIN SP_ADD_CHAR (UC (CH), SEGMENT_OPTIONS.COMMENT); INDEX := INDEX + 1; CH := FT_GET_CHAR (LINE, INDEX); END (*WHILE*); IF NOT SP_IS_EMPTY_STR (SEGMENT_OPTIONS.COMMENT) THEN BEGIN SP_EXTR_STR (SEGMENT_OPTIONS.COMMENT, STRING132); IF (STRING132.BODY = PASCAL_STRING) OR (STRING132.BODY = FORTRAN_STRING) OR (STRING132.BODY = C_STRING) THEN BEGIN DIAG (WARN, 'SCAN_OPTIONS (3.2.3)a ', DUMMY_LINE, SEGMENT, STRING132); SP_INIT_STR (SEGMENT_OPTIONS.COMMENT); OPTION_KEYWORD := EMPTY_OPTION; END ELSE IF ((STRING132.BODY[1] <> 'O') OR (STRING132.BODY[2] <> 'N')) AND ((STRING132.BODY[1] <> 'O') OR (STRING132.BODY[2] <> 'F') OR (STRING132.BODY[3] <> 'F')) THEN BEGIN DIAG (ERR, 'SCAN_OPTIONS (3.2.3)b ', DUMMY_LINE, SEGMENT, STRING132); SP_INIT_STR (SEGMENT_OPTIONS.COMMENT); OPTION_KEYWORD := EMPTY_OPTION; END (*IF.IF*); END ELSE BEGIN (* The argument of the option COMMENT must be on the *) (* next line. Nothing remains to be done here *) END (*IF*); (************* End of SCAN_OPTIONS (3.2.3) *****************) IF NOT SP_IS_EMPTY_STR (SEGMENT_OPTIONS.COMMENT) THEN OPTION_KEYWORD := EMPTY_OPTION; END (*IF.IF.IF*); END ELSE BEGIN (********************* SCAN_OPTIONS (3.2.4) ********************) (** Character is illegal at this position. Skip to next **) (** OPTION_MARKER or to end of this line. Generate a diagnostic **) (** message using SEGMENT and LINE. **) STRING132.LENGTH := 1; STRING132.BODY[1] := CH; DIAG (ERR, 'SCAN_OPTIONS (3.2.4) ', DUMMY_LINE, SEGMENT, STRING132); OPTION_KEYWORD := EMPTY_OPTION; WHILE (CH <> RUN_INFO.OPTION_MARKER) AND (INDEX < LENGTH_LINE) DO BEGIN INDEX := INDEX + 1; CH := FT_GET_CHAR (LINE, INDEX); END (*WHILE*); (***************** End of SCAN_OPTIONS (3.2.4) *****************) END (*IF*); (***************** End of SCAN_OPTIONS (3.2) ***************) END (*IF*); END (*WHILE*); (***************** End of SCAN_OPTIONS (3) *************) (***************** SCAN_OPTIONS (4) ********************) (** Retrieve next LINE from SEGMENT. SEGMENT_EXHAUSTED **) (** becomes TRUE if the segment is exhausted. **) ST_GET_LINE (LINE); IF LINE.ID = 0 THEN SEGMENT_EXHAUSTED := TRUE; (************* End of SCAN_OPTIONS (4) *****************) END (*WHILE*); IF SEGMENT_EXHAUSTED THEN BEGIN (***************** SCAN_OPTIONS (5) ********************) (** Check SEGMENT_OPTIONS for any errors. and generate **) (** diagnostic message using SEGMENT if appropriate. **) FT_INIT_LINE (DUMMY_LINE); (* 1. Check for a missing argument of the last option. *) (* This can be detected by a non-empty OPTION_KEYWORD.*) IF OPTION_KEYWORD <> EMPTY_OPTION THEN BEGIN STRING132.LENGTH := 0; STRING132.BODY := EMPTY_STRING_FIXED; FOR I := 1 TO MAX_OPTION_LENGTH DO BEGIN IF OPTION_KEYWORD[I] <> ' ' THEN BEGIN STRING132.BODY[I] := OPTION_KEYWORD[I]; STRING132.LENGTH := STRING132.LENGTH + 1; END (*IF*); END (*FOR*); DIAG (ERR, 'SCAN_OPTIONS (5a) ', DUMMY_LINE, SEGMENT, STRING132); END (*IF*); (* 2. Check the use of stub options in a slot SEGMENT. *) IF (SEGMENT_TYPE = SLOT) OR (SEGMENT_TYPE = CODE) THEN BEGIN IF SEGMENT_OPTIONS.QUICK THEN BEGIN SEGMENT_OPTIONS.QUICK := FALSE; STRING132.BODY[1] := 'Q'; STRING132.BODY[2] := 'U'; STRING132.BODY[3] := 'I'; STRING132.BODY[4] := 'C'; STRING132.BODY[5] := 'K'; STRING132.LENGTH := 5; DIAG (ERR, 'SCAN_OPTIONS (5b) ', DUMMY_LINE, SEGMENT, STRING132); END (*IF*); IF NOT (SP_IS_EMPTY_STR (SEGMENT_OPTIONS.FILE_NAME)) THEN BEGIN SP_INIT_STR (SEGMENT_OPTIONS.FILE_NAME); STRING132.BODY[1] := 'F'; STRING132.BODY[2] := 'I'; STRING132.BODY[3] := 'L'; STRING132.BODY[4] := 'E'; STRING132.LENGTH := 4; DIAG (ERR, 'SCAN_OPTIONS (5b) ', DUMMY_LINE, SEGMENT, STRING132); END (*IF*); IF SEGMENT_OPTIONS.OVERRULE THEN BEGIN SEGMENT_OPTIONS.OVERRULE := FALSE; AUX_STRING10 := 'OVERRULE '; FOR I:= 1 TO 8 DO STRING132.BODY[I] := AUX_STRING10[I]; STRING132.LENGTH := 8; DIAG (ERR, 'SCAN_OPTIONS (5b) ', DUMMY_LINE, SEGMENT, STRING132); END (*IF*); IF SEGMENT_OPTIONS.LEADER THEN BEGIN SEGMENT_OPTIONS.LEADER := FALSE; AUX_STRING10 := 'LEADER '; FOR I := 1 TO 6 DO STRING132.BODY[I] := AUX_STRING10[I]; STRING132.LENGTH := 6; DIAG (ERR, 'SCAN_OPTIONS (5b) ', DUMMY_LINE, SEGMENT, STRING132); END (*IF*); IF SEGMENT_OPTIONS.TRAILER THEN BEGIN SEGMENT_OPTIONS.TRAILER := FALSE; AUX_STRING10 := 'TRAILER '; FOR I:= 1 TO 7 DO STRING132.BODY[I] := AUX_STRING10[I]; STRING132.LENGTH := 7; DIAG (ERR, 'SCAN_OPTIONS (5b) ', DUMMY_LINE, SEGMENT, STRING132); END (*IF*); IF SEGMENT_OPTIONS.SEPARATOR THEN BEGIN SEGMENT_OPTIONS.SEPARATOR := FALSE; AUX_STRING10 := 'SEPARATOR '; FOR I := 1 TO 9 DO STRING132.BODY[I] := AUX_STRING10[I]; STRING132.LENGTH := 9; DIAG (ERR, 'SCAN_OPTIONS (5b) ', DUMMY_LINE, SEGMENT, STRING132); END (*IF*); IF SEGMENT_OPTIONS.DEFAULT THEN BEGIN SEGMENT_OPTIONS.QUICK := FALSE; AUX_STRING10 := 'DEFAULT '; FOR I := 1 TO 7 DO STRING132.BODY[I] := AUX_STRING10[I]; STRING132.LENGTH := 7; DIAG (ERR, 'SCAN_OPTIONS (5b) ', DUMMY_LINE, SEGMENT, STRING132); END (*IF*); END (* 3. Check the use of slot options in a stub segment. *) ELSE IF SEGMENT_TYPE = STUB THEN BEGIN IF SEGMENT_OPTIONS.MULTIPLE THEN BEGIN SEGMENT_OPTIONS.MULTIPLE := FALSE; AUX_STRING10 := 'MULTIPLE '; FOR I := 1 TO 8 DO STRING132.BODY[I] := AUX_STRING10[I]; STRING132.LENGTH := 8; DIAG (ERR, 'SCAN_OPTIONS (5c) ', DUMMY_LINE, SEGMENT, STRING132); END (*IF*); IF SEGMENT_OPTIONS.OPTIONAL THEN BEGIN SEGMENT_OPTIONS.OPTIONAL := FALSE; AUX_STRING10 := 'OPTIONAL '; FOR I := 1 TO 8 DO STRING132.BODY[I] := AUX_STRING10[I]; STRING132.LENGTH := 8; DIAG (ERR, 'SCAN_OPTIONS (5c) ', DUMMY_LINE, SEGMENT, STRING132); END (*IF*); END (*IF*); (* 4. Check illegal use of the options FILE, LEADER, *) (* TRAILER, SEPARATOR and DEFAULT in the segment. *) WITH SEGMENT_OPTIONS DO BEGIN IF ( (NOT SP_IS_EMPTY_STR (FILE_NAME)) AND ( (DEFAULT) OR (SEPARATOR) OR (LEADER) OR (TRAILER))) OR ( (DEFAULT) AND ( (SEPARATOR) OR (LEADER) OR (TRAILER))) OR ( (LEADER) AND ( (SEPARATOR) OR (TRAILER))) OR ( (SEPARATOR) AND (TRAILER)) THEN BEGIN DEFAULT := FALSE; SEPARATOR := FALSE; LEADER := FALSE; TRAILER := FALSE; STRING132.LENGTH := 0; STRING132.BODY := EMPTY_STRING_FIXED; DIAG (ERR, 'SCAN_OPTIONS (5d) ', DUMMY_LINE, SEGMENT, STRING132); END (*IF*); END (*WITH*); (***************** End of SCAN_OPTIONS (5) *************) END (*IF*); END (*IF*); (***************** End of SCAN_OPTIONS (body) ******************) END (*PROCEDURE SCAN_OPTIONS*); (*********************************************************************) (* Routine: BUILD_CODE_STRUCT - BUILD the structure CODE_STRUCT. *) (* Purpose: Scan a stub block upon the different sort of *) (* segments and build the structure of stubs and slots. *) (* Interface: CODE_STRUCT: Anchors the datastructure representing *) (* the stubs and slots structure. *) (* RUN_INFO: All information concerning this run. *) (* FIRST_LINE: The first line of a stub block. *) (* LINE_INFO: Scanned information of a line. *) (*********************************************************************) PROCEDURE BUILD_CODE_STRUCT (VAR CODE_STRUCT: CODE_STRUCT_; RUN_INFO: RUN_INFO_; FIRST_LINE: LINE_DES_; LINE_INFO: LINE_INFO_); VAR SEGMENT_TYPE: SEGMENT_TYPE_; END_OF_STUB_BLOCK: BOOLEAN; SOURCE_LINE: LINE_DES_; LAST_SLOT: SLT_PTR_; STRING132: STRING132_; SEGMENT: SEGMENT_DES_; BEGIN (******* BUILD_CODE_STRUCT (body) *******) (********************* BUILD_CODE_STRUCT (1) *******************) (** FIRST_LINE marks a new stub segment. Link the stub into its **) (** position and let CODE_STRUCT.LAST_STUB refer to it. Set **) (** LAST_SLOT to NIL. Initialize LAST_STUB. Add FIRST_LINE to **) (** the segment LAST_STUB^.SRC_IMG. Use LINE_INFO to update **) (** LAST_STUB^.NAME. **) WITH CODE_STRUCT DO BEGIN LAST_SLOT := NIL; IF FIRST_STUB = NIL THEN BEGIN NEW (FIRST_STUB); LAST_STUB := FIRST_STUB; END ELSE BEGIN NEW (LAST_STUB^.NEXT_STUB); LAST_STUB := LAST_STUB^.NEXT_STUB; END (*IF*); WITH LAST_STUB^ DO BEGIN SLOTS := NIL; NEXT_STUB := NIL; NEXT_TWIN := NIL; ST_INIT_SEG (SRC_IMG); SP_INIT_STR (NAME); ST_PUT_SEG (FIRST_LINE, SRC_IMG); SP_ADD_BUFFER (LINE_INFO.LINE_ID); SP_CONC_STR (NAME, LINE_INFO.LINE_ID); END (*WITH*); END (*WITH*); (***************** End of BUILD_CODE_STRUCT (1) ****************) (* Set SEGMENT_TYPE to STUB since the first segment of a stub *) (* block must be a stub segment. Initialize END_OF_STUB_BLOCK. *) SEGMENT_TYPE := STUB; END_OF_STUB_BLOCK := FALSE; WHILE (NOT END_OF_STUB_BLOCK) AND (NOT FT_EOF) DO BEGIN FT_RDLN (SOURCE_LINE); (* Check wether or not we need to scan this line. *) WITH RUN_INFO DO BEGIN IF FT_GET_LINE_LENGTH (SOURCE_LINE) > CLIP_LPAR.LENGTH+CLIP_RPAR.LENGTH THEN SCAN_LINE (LINE_INFO, SOURCE_LINE, RUN_INFO) ELSE LINE_INFO.CATEGORY := L5; END (*WITH*); WITH CODE_STRUCT DO CASE LINE_INFO.CATEGORY OF L1: BEGIN IF LAST_SLOT = NIL THEN BEGIN (************* BUILD_CODE_STRUCT (2) ***************) (** The end of the previous stub segment. Scan the **) (** options of LAST_STUB^.SRC_IMG and store the **) (** found options in LAST_STUB^.OPTIONS. Add the **) (** buffer to LINE_INFO.LINE_ID. **) WITH LAST_STUB^ DO SCAN_OPTIONS (OPTIONS, SRC_IMG, RUN_INFO, SEGMENT_TYPE); LINE_INFO.OPTIONS := FALSE; SP_ADD_BUFFER (LINE_INFO.LINE_ID); (********* End of BUILD_CODE_STRUCT (2) ************) IF LAST_STUB^.OPTIONS.QUICK THEN BEGIN SEGMENT_TYPE := STUB; (************* BUILD_CODE_STRUCT (3) ***********) (** The end of the current stub block and the **) (** start a new one. Make an entry for this new **) (** stub, let LAST_STUB point to it and initia- **) (** lize its fields. Set LAST_SLOT to NIL. Add **) (** SOURCE_LINE to LAST_STUB^.SRC_IMG. Update **) (** LAST_STUB^.NAME with information from **) (** LINE_INFO. **) NEW (LAST_STUB^.NEXT_STUB); LAST_STUB := LAST_STUB^.NEXT_STUB; LAST_SLOT := NIL; WITH LAST_STUB^ DO BEGIN SLOTS := NIL; NEXT_STUB := NIL; NEXT_TWIN := NIL; ST_INIT_SEG (SRC_IMG); SP_INIT_STR (NAME); ST_PUT_SEG (SOURCE_LINE, SRC_IMG); SP_CONC_STR (NAME, LINE_INFO.LINE_ID); END (*WITH*); (********* End of BUILD_CODE_STRUCT (3) ********) END ELSE BEGIN SEGMENT_TYPE := SLOT; (************* BUILD_CODE_STRUCT (4) ***********) (** First slot segment of this stub block. Make **) (** entry for this new slot, let LAST_SLOT **) (** point to it and initialize its fields. Add **) (** SOURCE_LINE to segment LAST_SLOT^.SRC_IMG. **) (** Update LAST_SLOT with the information hold **) (** by LINE_INFO. **) NEW (LAST_STUB^.SLOTS); LAST_SLOT := LAST_STUB^.SLOTS; WITH LAST_SLOT^ DO BEGIN SP_INIT_STR (NAME); ST_INIT_SEG (SRC_IMG); STUB_REF := NIL; ST_INIT_SEG (CODE); NEXT_SLOT := NIL; ST_PUT_SEG (SOURCE_LINE, SRC_IMG); SP_CONC_STR (NAME, LINE_INFO.LINE_ID); END (*WITH*); (********* End of BUILD_CODE_STRUCT (4) ********) END (*IF*); END ELSE BEGIN (************* BUILD_CODE_STRUCT (5) ***************) (** End of the previous segment LAST_SLOT^.SRC_IMG. **) (** Finish the segment by scanning its options **) (** using RUN_INFO. Store found options in **) (** LAST_SLOT^.OPTIONS. Add the buffer to LINE_- **) (** INFO.LINE_ID. **) WITH LAST_SLOT^ DO SCAN_OPTIONS (OPTIONS, SRC_IMG, RUN_INFO, SEGMENT_TYPE); LINE_INFO.OPTIONS := FALSE; SP_ADD_BUFFER (LINE_INFO.LINE_ID); (********* End of BUILD_CODE_STRUCT (5) ************) IF LAST_STUB^.OPTIONS.QUICK THEN BEGIN SEGMENT_TYPE := STUB; (************* BUILD_CODE_STRUCT (6) ***********) (** End of current stub block and the start of **) (** a new one. Link this new stub into its po- **) (** sition, let LAST_STUB point to it and ini- **) (** tialize its fields. Add SOURCE_LINE to **) (** segment LAST_STUB^.SRC_IMG and update **) (** LAST_STUB^.NAME with the help of LINE_INFO. **) NEW (LAST_STUB^.NEXT_STUB); LAST_STUB := LAST_STUB^.NEXT_STUB; LAST_SLOT := NIL; WITH LAST_STUB^ DO BEGIN SLOTS := NIL; NEXT_STUB := NIL; NEXT_TWIN := NIL; ST_INIT_SEG (SRC_IMG); SP_INIT_STR (NAME); ST_PUT_SEG (SOURCE_LINE, SRC_IMG); SP_CONC_STR (NAME, LINE_INFO.LINE_ID); END (*WITH*); (********* End of BUILD_CODE_STRUCT (6) ********) END ELSE BEGIN SEGMENT_TYPE := SLOT; (************* BUILD_CODE_STRUCT (7) ***********) (** Start of a new slot segment. Link slot into **) (** its position, let LAST_SLOT point to it and **) (** initialize its fields. Add SOURCE_LINE to **) (** LAST_SLOT^.SRC_IMG and update LAST_SLOT^.- **) (** NAME with the help of LINE_INFO. **) NEW (LAST_SLOT^.NEXT_SLOT); LAST_SLOT := LAST_SLOT^.NEXT_SLOT; WITH LAST_SLOT^ DO BEGIN SP_INIT_STR (NAME); ST_INIT_SEG (SRC_IMG); STUB_REF := NIL; ST_INIT_SEG (CODE); NEXT_SLOT := NIL; ST_PUT_SEG (SOURCE_LINE, SRC_IMG); SP_CONC_STR (NAME, LINE_INFO.LINE_ID); END (*WITH*); (********* End of BUILD_CODE_STRUCT (7) ********) END (*IF*); END(*IF*); END; L2: BEGIN (***************** BUILD_CODE_STRUCT (8) ***************) (** End of the previous slot or stub segment. Scan **) (** LAST_<x>^.SRC_IMG for options and store them in **) (** LAST_<x>^.OPTIONS. Add the buffer to LINE_INFO.- **) (** LINE_ID after that. <x> reads "STUB" for a stub **) (** and "SLOT" for a slot- or code-segment. **) IF (SEGMENT_TYPE = STUB) THEN BEGIN WITH LAST_STUB^ DO SCAN_OPTIONS (OPTIONS, SRC_IMG, RUN_INFO, SEGMENT_TYPE) END ELSE BEGIN WITH LAST_SLOT^ DO SCAN_OPTIONS (OPTIONS, SRC_IMG, RUN_INFO, SEGMENT_TYPE); END (*IF*); LINE_INFO.OPTIONS := FALSE; SP_ADD_BUFFER (LINE_INFO.LINE_ID); (************* End of BUILD_CODE_STRUCT (8) ************) END_OF_STUB_BLOCK := TRUE; SEGMENT_TYPE := END_STUB; (***************** BUILD_CODE_STRUCT (9) ***************) (** Start of the end segment. Link slot into its posi- **) (** tion, let LAST_SLOT point to it and initialize its **) (** fields. Add SOURCE_LINE to the segment LAST_SLOT^.- **) (** SRC_IMG and update LAST_SLOT^.NAME using the infor- **) (** mation of LINE_INFO. **) IF LAST_SLOT<>NIL THEN BEGIN NEW (LAST_SLOT^.NEXT_SLOT); LAST_SLOT := LAST_SLOT^.NEXT_SLOT; END ELSE BEGIN NEW (LAST_STUB^.SLOTS); LAST_SLOT := LAST_STUB^.SLOTS; END (*IF*); WITH LAST_SLOT^ DO BEGIN SP_INIT_STR (NAME); ST_INIT_SEG (SRC_IMG); STUB_REF := NIL; ST_INIT_SEG (CODE); NEXT_SLOT := NIL; SCAN_OPTIONS (OPTIONS, SRC_IMG, RUN_INFO, SEGMENT_TYPE); LINE_INFO.OPTIONS := FALSE; ST_PUT_SEG (SOURCE_LINE, SRC_IMG); SP_CONC_STR (NAME, LINE_INFO.LINE_ID); END; (*WITH*) (************* End of BUILD_CODE_STRUCT (9) ************) END; L3: BEGIN IF SEGMENT_TYPE = STUB THEN BEGIN (************* BUILD_CODE_STRUCT (10) **************) (** Continuation line of the stub segment. Add **) (** SOURCE_LINE to LAST_STUB^.SRC_IMG. Add buffer **) (** to LINE_INFO.LINE_ID and update LAST_STUB^.NAME **) (** using LINE_INFO. **) WITH LAST_STUB^ DO BEGIN ST_PUT_LINE (SOURCE_LINE, SRC_IMG); SP_ADD_BUFFER (LINE_INFO.LINE_ID); SP_CONC_STR (NAME, LINE_INFO.LINE_ID); END (*WITH*); (********* End of BUILD_CODE_STRUCT (10) ***********) END ELSE IF SEGMENT_TYPE = SLOT THEN BEGIN (************* BUILD_CODE_STRUCT (11) **************) (** Continuation of the current slot segment. **) (** Add SOURCE_LINE to LAST_SLOT^.SRC_IMG, add the **) (** buffer to LINE_INFO.LINE_ID and update LAST_- **) (** SLOT^.NAME using LINE_INFO. **) WITH LAST_SLOT^ DO BEGIN ST_PUT_LINE (SOURCE_LINE, SRC_IMG); SP_ADD_BUFFER (LINE_INFO.LINE_ID); SP_CONC_STR (NAME, LINE_INFO.LINE_ID); END (*WITH*); (********* End of BUILD_CODE_STRUCT (11) ***********) END ELSE BEGIN (************* BUILD_CODE_STRUCT (12) **************) (** This orphan line cannot be paste to a stub- or **) (** slot-segment. Generate an error message using **) (** the information hold by SOURCE_LINE. **) ST_INIT_SEG (SEGMENT); STRING132.LENGTH := 0; STRING132.BODY := EMPTY_STRING_FIXED; DIAG (WARN, 'BUILD_C_S (12) ', SOURCE_LINE, SEGMENT, STRING132); (********* End of BUILD_CODE_STRUCT (12) ***********) END (*IF.IF*); END; L4: BEGIN IF SEGMENT_TYPE = STUB THEN BEGIN (************* BUILD_CODE_STRUCT (13) **************) (** Continuation ofcurrent stub segment. Add **) (** SOURCE_LINE to segment LAST_STUB^.SRC_IMG. **) WITH LAST_STUB^ DO ST_PUT_LINE (SOURCE_LINE, SRC_IMG); (********* End of BUILD_CODE_STRUCT (13) ***********) END ELSE IF SEGMENT_TYPE = SLOT THEN BEGIN (************* BUILD_CODE_STRUCT (14) **************) (** Continuation of current slot segment. Add **) (** SOURCE_LINE to segment LAST_SLOT^.SRC_IMG. **) WITH LAST_SLOT^ DO ST_PUT_LINE (SOURCE_LINE, SRC_IMG); (********* End of BUILD_CODE_STRUCT (14) ***********) END ELSE IF SEGMENT_TYPE = CODE THEN BEGIN (************* BUILD_CODE_STRUCT (15) **************) (** Continuation of current code segment. Add **) (** SOURCE_LINE to segment LAST_SLOT^.CODE. **) WITH LAST_SLOT^ DO ST_PUT_LINE (SOURCE_LINE, CODE); (********* End of BUILD_CODE_STRUCT (15) ***********) END (*IF.IF.IF*); END; L5: BEGIN IF SEGMENT_TYPE = STUB THEN BEGIN (************* BUILD_CODE_STRUCT (16) **************) (** End of previous stub segment LAST_STUB^.- **) (** SRC_IMG. Complete that segment by scanning **) (** which are stored to LAST_STUB^.OPTIONS. **) WITH LAST_STUB^ DO SCAN_OPTIONS (OPTIONS, SRC_IMG, RUN_INFO, SEGMENT_TYPE); LINE_INFO.OPTIONS := FALSE; (********* End of BUILD_CODE_STRUCT (16) ***********) IF (LAST_STUB^.OPTIONS.QUICK) AND (FT_GET_LINE_LENGTH (SOURCE_LINE) = 0) THEN BEGIN (************* BUILD_CODE_STRUCT (17) **********) (** End of current stub block. Set Boolean **) (** END_OF_STUB_BLOCK to TRUE. **) END_OF_STUB_BLOCK := TRUE; (********* End of BUILD_CODE_STRUCT (17) *******) END ELSE BEGIN SEGMENT_TYPE := CODE; (************* BUILD_CODE_STRUCT (18) **********) (** Start of a new code-segment. Link a new **) (** entry for this slot into its position. Let **) (** LAST_SLOT refer to this slot and initialize **) (** its fields. Add SOURCE_LINE to the new code **) (** segment LAST_SLOT^.CODE. **) NEW (LAST_STUB^.SLOTS); LAST_SLOT := LAST_STUB^.SLOTS; WITH LAST_SLOT^ DO BEGIN SP_INIT_STR (NAME); ST_INIT_SEG (SRC_IMG); STUB_REF := NIL; ST_INIT_SEG (CODE); NEXT_SLOT := NIL; ST_PUT_SEG (SOURCE_LINE, CODE); END (*WITH*); (********* END OF BUILD_CODE-STRUCT (18) *******) END (*IF.IF*); END ELSE IF SEGMENT_TYPE = SLOT THEN BEGIN SEGMENT_TYPE := CODE; (************* BUILD_CODE_STRUCT (19) **************) (** Start of a new code segment immediately follo- **) (** wing a slot segment. Add SOURCE_LINE to the **) (** to the code segment LAST_SLOT^.CODE. **) WITH LAST_SLOT^ DO ST_PUT_SEG (SOURCE_LINE, CODE); (********* End of BUILD_CODE_STRUCT (19) ***********) END ELSE IF SEGMENT_TYPE = CODE THEN BEGIN IF (CODE_STRUCT.LAST_STUB^.OPTIONS.QUICK) AND (FT_GET_LINE_LENGTH (SOURCE_LINE)=0) THEN BEGIN (************* BUILD_CODE_STRUCT (20) **********) (** End of current stub block. Scan options **) (** from LAST_SLOT^.SRC_IMG and store them in **) (** LAST_SLOT^.OPTIONS. **) SCAN_OPTIONS (LAST_SLOT^.OPTIONS, LAST_SLOT^.SRC_IMG, RUN_INFO, SEGMENT_TYPE); LINE_INFO.OPTIONS := FALSE; (********* End of BUILD_CODE_STRUCT (20) *******) END_OF_STUB_BLOCK := TRUE; END ELSE BEGIN (************* BUILD_CODE_STRUCT (21) **********) (** Continuation of the code segment. Add **) (** SOURCE_LINE to segment LAST_SLOT^.CODE. **) WITH LAST_SLOT^ DO ST_PUT_LINE (SOURCE_LINE, CODE); (********* End of BUILD_CODE_STRUCT (21) *******) END (*IF*); END (*IF.IF.IF*); END; END (*CASE.WITH*); END (*WHILE*); IF (NOT END_OF_STUB_BLOCK) THEN BEGIN IF (NOT CODE_STRUCT.LAST_STUB^.OPTIONS.QUICK) THEN BEGIN (************* BUILD_CODE_STRUCT (22) ******************) (** File exhausted but current stub block not closed by **) (** a line of category L2. Issue an error using **) (** FILE_SPEC. **) STRING132.LENGTH := 0; STRING132.BODY := EMPTY_STRING_FIXED; FT_INIT_LINE (SOURCE_LINE); DIAG (WARN, 'BUILD_C_S (22) ', SOURCE_LINE, CODE_STRUCT.LAST_STUB^.SRC_IMG, STRING132); (************* End of BUILD_CODE_STRUCT (22) ***********) END ELSE IF SEGMENT_TYPE = CODE THEN BEGIN (************* BUILD_CODE_STRUCT (23) ******************) (** The last quick stub in the file didn't end with an **) (** L5-line, but with EOF. So the options from LAST_- **) (** SLOT.SRC_IMG must be scanned and stored in LAST_- **) (** SLOT.OPTIONS here. **) SCAN_OPTIONS (LAST_SLOT^.OPTIONS, LAST_SLOT^.SRC_IMG, RUN_INFO, SEGMENT_TYPE); LINE_INFO.OPTIONS := FALSE; (************* End of BUILD_CODE_STRUCT (23) ***********) END (*IF*); END (*IF*); (************* End of BUILD_CODE_STRUCT (body) *****************) END (*PROCEDURE BUILD_CODE_STRUCT*); (*********************************************************************) (* Routine: SCAN_FILES - SCAN all source FILES. *) (* Purpose: To coordinate the scanning of all the sourcefiles on *) (* file level. More detailed activities are delegated. *) (* Interface: RUN_INFO: Structure containing all needed info *) (* for this CLIP run. *) (* CODE_STRUCT: Internal representation of stub-, *) (* slot- and code-segments. *) (*********************************************************************) PROCEDURE SCAN_FILES (VAR CODE_STRUCT: CODE_STRUCT_; RUN_INFO: RUN_INFO_); VAR SCAN_FILE_STOP: BOOLEAN; FILE_CNT: INTEGER; I: INTEGER; LINE_INFO: LINE_INFO_ ; SOURCE_LINE: LINE_DES_ ; DUMMY: ERROR_CODE_; STRING132: STRING132_; SEGMENT: SEGMENT_DES_; BEGIN (******* SCAN_FILES (body) *******) SCAN_FILE_STOP := FALSE; (********************* SCAN_FILES (1) **************************) (** Try to open all source files of which the names are kept by **) (** RUN_INFO. List inaccessible files. Set SCAN_FILE_STOP to **) (** TRUE when at least one file gives a problem. **) WITH RUN_INFO DO FOR FILE_CNT := 1 TO NR_SRC_FILES DO BEGIN IF FT_CHECK_FILE (SOURCE_FILES [FILE_CNT]) <> 0 THEN BEGIN WRITE ('ERROR checking source file: '); FOR I := 1 TO SOURCE_FILES [FILE_CNT].LENGTH DO WRITE (SOURCE_FILES [FILE_CNT].BODY [I]); WRITELN; IF REPORT_OK THEN BEGIN WRITE (REPORT_FILE, 'ERROR checking source file: '); FOR I := 1 TO SOURCE_FILES [FILE_CNT].LENGTH DO WRITE (REPORT_FILE, SOURCE_FILES [FILE_CNT].BODY [I]); WRITELN (REPORT_FILE); END (*IF*); SCAN_FILE_STOP := TRUE; END (*IF*); END (*FOR.WITH*); (***************** End of SCAN_FILES (1) ***********************) IF NOT SCAN_FILE_STOP THEN BEGIN (********************* SCAN_FILES (2) **********************) (** Build CODE_STRUCT from the source files specified by **) (** RUN_INFO. **) FOR FILE_CNT := 1 TO RUN_INFO.NR_SRC_FILES DO BEGIN (* Open and reset file with given specification using *) (* the function FT_INOPEN from the module FT. *) IF FT_INOPEN (RUN_INFO.SOURCE_FILES [FILE_CNT]) <= 0 THEN BEGIN WRITE ('Scanning file: '); FOR I := 1 TO RUN_INFO.SOURCE_FILES [FILE_CNT].LENGTH DO WRITE (RUN_INFO.SOURCE_FILES [FILE_CNT].BODY[I]); WRITELN; IF REPORT_OK THEN BEGIN WRITE (REPORT_FILE, 'Scanning file: '); FOR I := 1 TO RUN_INFO.SOURCE_FILES [FILE_CNT].LENGTH DO WRITE (REPORT_FILE, RUN_INFO.SOURCE_FILES [FILE_CNT].BODY[I]); WRITELN (REPORT_FILE); END (*IF*); WHILE NOT FT_EOF DO BEGIN (* Read the next line from the source file and *) (* initialize LINE_INFO and the Buffer. *) FT_RDLN (SOURCE_LINE); WITH LINE_INFO DO OPTIONS := FALSE; SP_INIT_BUFFER; (* Determine the category this line belongs to. *) WITH RUN_INFO DO BEGIN IF SOURCE_LINE.USED > CLIP_LPAR.LENGTH + CLIP_RPAR.LENGTH THEN SCAN_LINE (LINE_INFO, SOURCE_LINE, RUN_INFO) ELSE LINE_INFO.CATEGORY := L5; END (*WITH*); (* Proces this line according to its catagory. *) CASE LINE_INFO.CATEGORY OF L1: BEGIN (************* SCAN_FILES (2.1) ********************) (** Start of a new stub. Switch to active mode and **) (** build CODE_STRUCT from successive lines using **) (** RUN_INFO, SOURCE_LINE and LINE_INFO. **) BUILD_CODE_STRUCT (CODE_STRUCT, RUN_INFO, SOURCE_LINE, LINE_INFO); (************* End of SCAN_FILES (2.1) *************) END; L2: BEGIN (************* SCAN_FILES (2.2) ********************) (** Illegal in passive mode. Generate an error from **) (** the information in SOURCE_LINE. **) ST_INIT_SEG (SEGMENT); STRING132.BODY := EMPTY_STRING_FIXED; STRING132.LENGTH := 0; DIAG (WARN, 'SCAN_FILES (2.2) ', SOURCE_LINE, SEGMENT, STRING132); (************* End of SCAN_FILES (2.2) *************) END; L3: BEGIN (************* SCAN_FILES (2.3) ********************) (** Illegal in passive mode. Generate an error from **) (** the information in SOURCE_LINE. **) ST_INIT_SEG (SEGMENT); STRING132.LENGTH := 0; STRING132.BODY := EMPTY_STRING_FIXED; DIAG (ERR, 'SCAN_FILES (2.3) ', SOURCE_LINE, SEGMENT, STRING132); (************* End of SCAN_FILES (2.3) *************) END; L4, L5: BEGIN (* Nothing to be done. Flush this line. *) END; END (*CASE*); END (*WHILE*); DUMMY := FT_INCLOSE; END ELSE BEGIN (********************* SCAN_FILES (2.4) ********************) (** Access problem with this source file. Issue error using **) (** its specification in RUN_INFO. **) WITH RUN_INFO DO BEGIN WRITE ('ERROR opening source file: '); FOR I := 1 TO SOURCE_FILES [FILE_CNT].LENGTH DO WRITE (SOURCE_FILES [FILE_CNT].BODY [I]); WRITELN; IF REPORT_OK THEN BEGIN WRITE (REPORT_FILE, 'ERROR opening source file: '); FOR I := 1 TO SOURCE_FILES [FILE_CNT].LENGTH DO WRITE (REPORT_FILE, SOURCE_FILES [FILE_CNT].BODY [I]); WRITELN (REPORT_FILE); END (*IF*); END (*WITH*); (***************** End of SCAN_FILES (2.4) *****************) END (*IF*); END (*FOR*); (***************** End of SCAN_FILES (2) *******************) END (*IF*); (***************** End of SCAN_FILES (body) ********************) END (*PROCEDURE SCAN_FILES*); (*********************************************************************) (* Routine: CHECK_CIRC - CHECK FOR CIRCularity. *) (* Purpose: To check possible circularity of CODE_STRUCT. *) (* Interface: CODE_STRUCT - Structure to be examined. *) (* LIST_HEAD - First element of shadow list. *) (*********************************************************************) PROCEDURE CHECK_CIRC (VAR CODE_STRUCT: CODE_STRUCT_; LIST_HEAD: SHADOW_PTR_); VAR MAIN_STUB: STB_PTR_; SHADOW_STUB: SHADOW_PTR_; STUB: STB_PTR_; CIRCULARITY, REMOVED: BOOLEAN; (******* CHECK_CIRC routines *******) (*********************************************************************) (* Routine: LOCATE_CIRC - LOCATE CIRCularity. *) (* Purpose: Locate and remove circularity in CODE_STRUCT. *) (* Interface: CODE_STRUCT - The structure to be checked. *) (* STUB - The stub currently checked. *) (* CIRCULARITY - Flags if circularity is detected. *) (* REMOVED - Flags if circularity is removed. *) (*********************************************************************) PROCEDURE LOCATE_CIRC (VAR CODE_STRUCT: CODE_STRUCT_; VAR STUB: STB_PTR_; VAR CIRCULARITY: BOOLEAN; VAR REMOVED: BOOLEAN); (******* LOCATE_CIRC labels (#Quick) *******) LABEL MYEXIT; VAR SLOT: SLT_PTR_; HELP_STUB: STB_PTR_; TWIN_STUB: STB_PTR_; (******* LOCATE_CIRC routines *******) (*********************************************************************) (* Routine: TRACEBACK *) (* Purpose: -In case of an unremoved circularity: Remove circu- *) (* larity and show the responsible slot. *) (* -Show a stub of the circularity-chain. *) (* Interface: STUB - The stub, which was being checked. *) (* SLOT - The slot, at which STUB is pointing. *) (* REMOVED - Flags if the circularity is removed. *) (*********************************************************************) PROCEDURE TRACEBACK ( STUB: STB_PTR_; SLOT: SLT_PTR_; VAR REMOVED: BOOLEAN); BEGIN IF NOT REMOVED THEN BEGIN SLOT^.STUB_REF := NIL; REMOVED := TRUE; WRITELN('Circularity detected !!! TRACE BACK:'); WRITELN ('slot:'); ST_WRITE_SEG (SLOT^.SRC_IMG, 0, 0); WRITELN; IF REPORT_OK THEN BEGIN WRITELN (REPORT_FILE, 'Circularity detected !!! TRACE BACK:'); WRITELN (REPORT_FILE, 'slot:'); ST_WRITE_SEG (SLOT^.SRC_IMG, 0, 3); WRITELN (REPORT_FILE); END (*IF*); END(*IF*); IF NOT SP_IS_EMPTY_STR (STUB^.OPTIONS.FILE_NAME) THEN BEGIN WRITELN ('Main stub:'); ST_WRITE_SEG (STUB^.SRC_IMG, 0, 0); WRITELN ('------------------------------------', '------------------------------------'); IF REPORT_OK THEN BEGIN WRITELN (REPORT_FILE, 'Main stub:'); ST_WRITE_SEG (STUB^.SRC_IMG, 0, 3); WRITELN (REPORT_FILE, '------------------------------------', '------------------------------------'); END (*IF*); END ELSE BEGIN WRITELN ('Stub:'); ST_WRITE_SEG (STUB^.SRC_IMG, 0, 0); IF REPORT_OK THEN BEGIN WRITELN (REPORT_FILE, 'Stub:'); ST_WRITE_SEG (STUB^.SRC_IMG, 0, 3); END (*IF*); END (*IF*); WRITELN; END (*TRACEBACK*); (********************* End of LOCATE_CIRC routines *****************) BEGIN (******* LOCATE_CIRC (body) *******) WITH STUB^ DO BEGIN CIRCULARITY := STUB^.VISITED; IF NOT CIRCULARITY THEN BEGIN STUB^.VISITED := TRUE; SLOT := STUB^.SLOTS; (********************* LOCATE_CIRC (1) *********************) (** Check if the SLOTs of STUB are pointing at any stubs. **) (** If so, locate circularities in these stubs and their **) (** structure behind. Leave this level of the procedure **) (** through MYEXIT in case of circularity. **) WHILE SLOT <> NIL DO BEGIN IF SLOT^.STUB_REF <> NIL THEN BEGIN LOCATE_CIRC(CODE_STRUCT,SLOT^.STUB_REF, CIRCULARITY,REMOVED); IF CIRCULARITY THEN BEGIN (***************** LOCATE_CIRC (1.1) *******************) (** Remove the link causing the circularity in CODE_- **) (** STRUCT, if not removed already. Mention STUB in the **) (** traceback. If this STUB is a main stub, set CIRCU- **) (** RITY, REMOVED and VISITED of all next stubs back to **) (** FALSE and locate circularities in this new CODE_- **) (** STRUCT. Leave this level of the procedure through **) (** MYEXIT. **) TRACEBACK (STUB, SLOT, REMOVED); IF NOT SP_IS_EMPTY_STR (STUB^.OPTIONS.FILE_NAME) THEN BEGIN CIRCULARITY := FALSE; REMOVED := FALSE; HELP_STUB := STUB; WHILE HELP_STUB <> NIL DO BEGIN HELP_STUB^.VISITED := FALSE; HELP_STUB := HELP_STUB^.NEXT_STUB; END (*WHILE*); LOCATE_CIRC (CODE_STRUCT, STUB, CIRCULARITY, REMOVED); END(*IF*); GOTO MYEXIT; (************* End of LOCATE_CIRC (1.1) ****************) END (*IF*); (***************** LOCATE_CIRC (1.2) ***********************) (** Check if SLOT^.STUB_REF is pointing at any twin stubs. **) (** If so, locate circularities in these stubs. In case of **) (** circularity, remove the responsible link, if not **) (** removed already, mention STUB in the traceback and **) (** leave this level of the procedure through MYEXIT. **) TWIN_STUB := SLOT^.STUB_REF^.NEXT_TWIN; WHILE TWIN_STUB <> NIL DO BEGIN LOCATE_CIRC (CODE_STRUCT, TWIN_STUB, CIRCULARITY, REMOVED); IF CIRCULARITY THEN BEGIN TRACEBACK (STUB, SLOT, REMOVED); GOTO MYEXIT; END (*IF*); TWIN_STUB := TWIN_STUB^.NEXT_TWIN; END (*WHILE*); (************* End of LOCATE_CIRC (1.2) ********************) SLOT^.STUB_REF^.VISITED := FALSE; END (*IF*); SLOT := SLOT^.NEXT_SLOT; END (*WHILE*); (***************** End of LOCATE_CIRC (1) ******************) STUB^.VISITED := FALSE; END (*IF*); END (*WITH*); MYEXIT: (***************** End of LOCATE_CIRC (body) *******************) END (*PROCEDURE LOCATE_CIRC*); (***************** End of procedure LOCATE_CIRC ********************) BEGIN SHADOW_STUB := LIST_HEAD; WHILE SHADOW_STUB <> NIL DO BEGIN MAIN_STUB := NIL; WITH SHADOW_STUB^.STUB_POINTER^ DO BEGIN IF NOT SP_IS_EMPTY_STR (OPTIONS.FILE_NAME) THEN MAIN_STUB := SHADOW_STUB^.STUB_POINTER; END (*WITH*); IF MAIN_STUB <> NIL THEN BEGIN STUB := CODE_STRUCT.FIRST_STUB; WHILE STUB <> NIL DO BEGIN STUB^.VISITED := FALSE; STUB := STUB^.NEXT_STUB; END (*WHILE*); CIRCULARITY := FALSE; REMOVED := FALSE; LOCATE_CIRC (CODE_STRUCT, MAIN_STUB, CIRCULARITY, REMOVED); END (*IF*); SHADOW_STUB := SHADOW_STUB^.NEXT; END (*WHILE*) END (*PROCEDURE CHECK_CIRC*); (*********************************************************************) (* Routine: ORDER_TWINS - ORDER TWIN stub chains. *) (* Purpose: To (re)order the chains of twin stubs. *) (* Interface: SHADOW_LIST: The list of pointers to the first *) (* elements of the twin stub chain. *) (* CODE_STRUCT: Structure of stubs and slots. *) (* LIST_HEAD: Pointer to first element of the *) (* shadow_list. *) (*********************************************************************) PROCEDURE ORDER_TWINS (VAR SHADOW_LIST: SHADOW_LIST_; VAR CODE_STRUCT: CODE_STRUCT_; VAR LIST_HEAD: SHADOW_PTR_); VAR FIRST_TWIN: STB_PTR_; SHADOW_STUB: SHADOW_PTR_; PREV_SHADOW_STUB: SHADOW_PTR_; TWIN_STUB: STB_PTR_; PREV_TWIN: STB_PTR_; CONTINUE: BOOLEAN; LAST_TWIN: STB_PTR_; SEPARATOR_STUB: STB_PTR_; STUB_WALKER: STB_PTR_; HELP_STUB: STB_PTR_; ERROR: BOOLEAN; DUMMY_LINE: LINE_DES_; STRING132: STRING132_; BEGIN (********************* ORDER_TWINS body ************************) PREV_SHADOW_STUB := NIL; SHADOW_STUB := LIST_HEAD; WHILE SHADOW_STUB <> NIL DO BEGIN FIRST_TWIN := SHADOW_STUB^.STUB_POINTER; (************************ ORDER_TWINS (1) *********************) (** Order the twin stub chain headed by FIRST_TWIN. Make sure **) (** that its first element remains accessible through by **) (** SHADOW_STUB. **) PREV_TWIN := NIL; TWIN_STUB := FIRST_TWIN; WHILE TWIN_STUB <> NIL DO BEGIN IF TWIN_STUB^.OPTIONS.DEFAULT THEN BEGIN (********************* ORDER_TWINS (1.1) *******************) (** Remove the TWIN_STUB from the list if it is no longer **) (** needed. Update SHADOW_LIST if needed. **) IF (TWIN_STUB^.NEXT_TWIN <> NIL) AND (PREV_TWIN = NIL) THEN SHADOW_STUB^.STUB_POINTER := TWIN_STUB^.NEXT_TWIN ELSE IF (TWIN_STUB^.NEXT_TWIN <> NIL) AND (PREV_TWIN <> NIL) THEN PREV_TWIN^.NEXT_TWIN := TWIN_STUB^.NEXT_TWIN ELSE IF (TWIN_STUB^.NEXT_TWIN = NIL) AND (PREV_TWIN <> NIL) THEN PREV_TWIN^.NEXT_TWIN := NIL ELSE BEGIN (* Nothing remains to be done here. *) END(*IF.IF.IF*); (***************** End of ORDER_TWINS (1.1) ****************) END (*IF*); IF TWIN_STUB^.OPTIONS.LEADER THEN BEGIN (********************* ORDER_TWINS (1.2) *******************) (** Remove TWIN_STUB and put it ahead of the twin stub **) (** chain. Remove SHADOW_STUB from SHADOW_LIST if TWIN_STUB **) (** is no longer needed. **) IF (TWIN_STUB^.NEXT_TWIN = NIL) AND (PREV_TWIN = NIL) THEN BEGIN IF PREV_SHADOW_STUB = NIL THEN BEGIN LIST_HEAD := SHADOW_STUB^.NEXT; SHADOW_STUB := LIST_HEAD; PREV_SHADOW_STUB := NIL; END ELSE BEGIN PREV_SHADOW_STUB^.NEXT := SHADOW_STUB^.NEXT; SHADOW_STUB := PREV_SHADOW_STUB; END (*IF*); END ELSE IF (TWIN_STUB^.NEXT_TWIN <> NIL) AND (PREV_TWIN <> NIL) THEN BEGIN PREV_TWIN^.NEXT_TWIN := TWIN_STUB^.NEXT_TWIN; TWIN_STUB^.NEXT_TWIN := FIRST_TWIN; SHADOW_STUB^.STUB_POINTER := TWIN_STUB; TWIN_STUB := PREV_TWIN; FIRST_TWIN := SHADOW_STUB^.STUB_POINTER; END ELSE IF (TWIN_STUB^.NEXT_TWIN = NIL) AND (PREV_TWIN <> NIL) THEN BEGIN PREV_TWIN^.NEXT_TWIN := NIL; TWIN_STUB^.NEXT_TWIN := FIRST_TWIN; SHADOW_STUB^.STUB_POINTER := TWIN_STUB; TWIN_STUB := PREV_TWIN; FIRST_TWIN := SHADOW_STUB^.STUB_POINTER; END ELSE BEGIN (* Leader stub is in place,nothing remains to be *) (* done here. *) END (*IF.IF.IF*); (***************** End of ORDER_TWINS (1.2) ****************) END (*IF*); IF TWIN_STUB^.OPTIONS.TRAILER THEN BEGIN (********************* ORDER_TWINS (1.3) *******************) (** Remove TWIN_STUB and put it at the tail of the twin **) (** stub chain. **) (* Locate the last stub in the twin stub chain *) LAST_TWIN := TWIN_STUB; WHILE LAST_TWIN^.NEXT_TWIN <> NIL DO LAST_TWIN := LAST_TWIN^.NEXT_TWIN; IF (TWIN_STUB^.NEXT_TWIN = NIL) AND (PREV_TWIN = NIL) THEN BEGIN IF PREV_SHADOW_STUB = NIL THEN BEGIN LIST_HEAD := SHADOW_STUB^.NEXT; SHADOW_STUB := LIST_HEAD; PREV_SHADOW_STUB := NIL; END ELSE BEGIN PREV_SHADOW_STUB^.NEXT := SHADOW_STUB^.NEXT; SHADOW_STUB := PREV_SHADOW_STUB; END (*IF*); END ELSE IF (TWIN_STUB^.NEXT_TWIN <> NIL) AND (PREV_TWIN <> NIL) THEN BEGIN PREV_TWIN^.NEXT_TWIN := TWIN_STUB^.NEXT_TWIN; LAST_TWIN^.NEXT_TWIN := TWIN_STUB; LAST_TWIN := LAST_TWIN^.NEXT_TWIN; LAST_TWIN^.NEXT_TWIN := NIL; TWIN_STUB := PREV_TWIN; END ELSE IF (TWIN_STUB^.NEXT_TWIN <> NIL) AND (PREV_TWIN = NIL) THEN BEGIN SHADOW_STUB^.STUB_POINTER := TWIN_STUB^.NEXT_TWIN; LAST_TWIN^.NEXT_TWIN := TWIN_STUB; LAST_TWIN := LAST_TWIN^.NEXT_TWIN; LAST_TWIN^.NEXT_TWIN := NIL; FIRST_TWIN := SHADOW_STUB^.STUB_POINTER; TWIN_STUB := FIRST_TWIN; PREV_TWIN := NIL; END ELSE BEGIN (* Trailer stub is in position. Nothing remains *) (* to be done. *) END (*IF.IF.IF*); (***************** End of ORDER_TWINS (1.3) ****************) END (*IF*); PREV_TWIN := TWIN_STUB; TWIN_STUB := TWIN_STUB^.NEXT_TWIN; END (*WHILE*); TWIN_STUB := FIRST_TWIN; PREV_TWIN := NIL; CONTINUE := TRUE; WHILE (TWIN_STUB^.NEXT_TWIN <> NIL) AND (CONTINUE) DO BEGIN IF TWIN_STUB^.OPTIONS.SEPARATOR THEN BEGIN (********************* ORDER_TWINS (1.4) *******************) (** Copy the seperator TWIN_STUB in between all other stubs **) (** of the twin stub chain. **) IF PREV_TWIN = NIL THEN BEGIN FIRST_TWIN := TWIN_STUB^.NEXT_TWIN; SHADOW_STUB^.STUB_POINTER := FIRST_TWIN; SEPARATOR_STUB := TWIN_STUB; END ELSE BEGIN PREV_TWIN^.NEXT_TWIN := TWIN_STUB^.NEXT_TWIN; SEPARATOR_STUB := TWIN_STUB; TWIN_STUB := PREV_TWIN; END (*IF*); STUB_WALKER := FIRST_TWIN; WHILE STUB_WALKER^.NEXT_TWIN <> NIL DO BEGIN HELP_STUB := STUB_WALKER^.NEXT_TWIN; NEW (STUB_WALKER^.NEXT_TWIN); STUB_WALKER := STUB_WALKER^.NEXT_TWIN; STUB_WALKER^ := SEPARATOR_STUB^; STUB_WALKER^.NEXT_TWIN := HELP_STUB; STUB_WALKER := HELP_STUB; END (*WHILE*); (***************** End of ORDER_TWINS (1.4) ****************) CONTINUE := FALSE; END (*IF*); PREV_TWIN := TWIN_STUB; TWIN_STUB := TWIN_STUB^.NEXT_TWIN; END (*WHILE*); (************************* ORDER_TWINS (1.5) ***********************) (** Examine the twin stub chain accessible by FIRST_TWIN. Generate **) (** a diagnostic message in case the chain contains only LEADER, **) (** SEPARATOR and TRAILER stubs. **) ERROR := TRUE; STUB_WALKER := FIRST_TWIN; WHILE (STUB_WALKER <> NIL) AND (ERROR = TRUE) DO BEGIN IF (NOT STUB_WALKER^.OPTIONS.LEADER) AND (NOT STUB_WALKER^.OPTIONS.SEPARATOR) AND (NOT STUB_WALKER^.OPTIONS.TRAILER) THEN ERROR := FALSE; STUB_WALKER := STUB_WALKER^.NEXT_TWIN; END (*WHILE*); IF (STUB_WALKER = NIL) AND (ERROR) THEN BEGIN STRING132.LENGTH := 0; STRING132.BODY := EMPTY_STRING_FIXED; FT_INIT_LINE (DUMMY_LINE); DIAG(WARN, 'ORDER_TWINS (1.5) ', DUMMY_LINE, FIRST_TWIN^.SRC_IMG, STRING132); IF PREV_SHADOW_STUB = NIL THEN BEGIN LIST_HEAD := SHADOW_STUB^.NEXT; SHADOW_STUB := LIST_HEAD; PREV_SHADOW_STUB := NIL; END ELSE BEGIN PREV_SHADOW_STUB^.NEXT := SHADOW_STUB^.NEXT; SHADOW_STUB := PREV_SHADOW_STUB; END (*IF*); END ELSE BEGIN (* The twin stub chain is ok and nothing remains to be *) (* done here. *) END (*IF*); (********************* End of ORDER_TWINS (1.5) ********************) (********************* End of ORDER_TWINS (1) ******************) PREV_SHADOW_STUB := SHADOW_STUB; SHADOW_STUB := SHADOW_STUB^.NEXT; END (*WHILE*); (***************** End of ORDER_TWINS (body) *******************) END (*PROCEDURE ORDER_TWINS*); (*********************************************************************) (* Routine: ANALYSE - ANALYSEr phase *) (* Purpose: To analyse the structure of stubs and slots. *) (* Interface: Input: CODE_STRUCT - the structure to be analyzed. *) (* Output: CODE_STRUCT - the analyzed structure. *) (*********************************************************************) PROCEDURE ANALYSE (VAR CODE_STRUCT: CODE_STRUCT_); VAR SHADOW_LIST: SHADOW_LIST_; LIST_HEAD: SHADOW_PTR_; STRING132: STRING132_; LAST_SHADOW: SHADOW_PTR_; STUB: STB_PTR_; LOCATED: BOOLEAN; SHADOW_STUB: SHADOW_PTR_; CANDIDATE_TWIN: STB_PTR_; SLOT: SLT_PTR_; STUB_REF: STB_PTR_; DUMMY_LINE: LINE_DES_; BEGIN (********************* ANALYSE body ****************************) LIST_HEAD := NIL; (************************* ANALYSE (1) *************************) (** Build SHADOW_LIST from the stub chain of CODE_STRUCT. Make **) (** first element of SHADOW_LIST accessible by LIST_HEAD **) STUB := CODE_STRUCT.FIRST_STUB; IF STUB <> NIL THEN BEGIN NEW (LIST_HEAD); LAST_SHADOW := LIST_HEAD; LAST_SHADOW^.NEXT := NIL; LAST_SHADOW^.STUB_POINTER := STUB; STUB := STUB^.NEXT_STUB; WHILE STUB <> NIL DO BEGIN (********************* ANALYSE (1.1) ***********************) (** Check if STUB^.NAME is already linked in SHADOW_LIST. **) (** If not, make a new entry for this stub in SHADOW_LIST **) (** and update LAST_SHADOW. **) IF SP_IS_EMPTY_STR (STUB^.NAME) THEN LOCATED := FALSE ELSE BEGIN SHADOW_STUB := LIST_HEAD; LOCATED := FALSE; WHILE (NOT LOCATED) AND (SHADOW_STUB <> NIL) DO BEGIN IF SP_EQ (SHADOW_STUB^.STUB_POINTER^.NAME, STUB^.NAME) THEN LOCATED := TRUE; SHADOW_STUB := SHADOW_STUB^.NEXT; END (*WHILE*); END (*IF*); IF NOT LOCATED THEN BEGIN NEW (LAST_SHADOW^.NEXT); LAST_SHADOW := LAST_SHADOW^.NEXT; LAST_SHADOW^.STUB_POINTER := STUB; LAST_SHADOW^.NEXT := NIL; END (*IF*); (***************** End of ANALYSE (1.1) ********************) STUB := STUB^.NEXT_STUB; END (*WHILE*); END (*IF*); (************************* End of ANALYSE (1) **********************) IF LIST_HEAD <> NIL THEN BEGIN (************************ ANALYSE (2) **********************) (** Link stubs with identical names into a twin stub chain **) (** using NEXT_TWIN of the stub descriptor. Start each twin **) (** stub chain with the stub accessible by SHADOW_LIST. **) SHADOW_STUB := LIST_HEAD; WHILE SHADOW_STUB <> NIL DO BEGIN STUB := SHADOW_STUB^.STUB_POINTER; IF NOT SP_IS_EMPTY_STR(STUB^.NAME) THEN WHILE STUB <> NIL DO BEGIN (***************** ANALYSE (2.1) *******************) (** Read through the list of stubs starting with **) (** STUB and set STUB^.NEXT_TWIN if a stub with **) (** the same name as STUB^.NAME found. Let **) (** CANDIDATE_TWIN refer to this stub. **) LOCATED := FALSE; CANDIDATE_TWIN := STUB^.NEXT_STUB; WHILE (CANDIDATE_TWIN <> NIL) AND (NOT LOCATED) DO BEGIN IF SP_EQ (STUB^.NAME, CANDIDATE_TWIN^.NAME) THEN BEGIN LOCATED := TRUE; STUB^.NEXT_TWIN := CANDIDATE_TWIN; END ELSE CANDIDATE_TWIN := CANDIDATE_TWIN^.NEXT_STUB; END (*WHILE*); (************* End of ANALYSE (2.1) ****************) STUB := CANDIDATE_TWIN; END (*WHILE*); SHADOW_STUB := SHADOW_STUB^.NEXT; END (*WHILE*); (********************* End of ANALYSE (2) ******************) (********************* ANALYSE (3) *************************) (** Reorder the twin stub chain by using the options of **) (** the stub. SHADOW_LIST.STUB_POINTER must always refer to **) (** the first stub of the twin stub chain. **) ORDER_TWINS (SHADOW_LIST, CODE_STRUCT, LIST_HEAD); (***************** End of ANALYSE (3) **********************) (********************* ANALYSE (4) *************************) (** Update the field STUB_REF of the slots in the structure **) (** by searching a stub with the same name as the slot in **) (** the structure. Use SHADOW_LIST to access the stubs. **) (** Check if the option SLOT^.OPTIONS.MULTIPLE is used **) (** correctly. Use SLOT^.SRC_IMG for diagnostics. **) STUB := CODE_STRUCT.FIRST_STUB; WHILE STUB <> NIL DO BEGIN SLOT := STUB^.SLOTS; WHILE SLOT <> NIL DO BEGIN (***************** ANALYSE (4.1) *******************) (** Use SHADOW_LIST to search a stub with the same **) (** name as SLOT^.NAME and update SLOT^.STUB_REF if **) (** such a stub is found. SLOT^.SRC_IMG serves for **) (** a diagnostic if multiple stubs are used in a **) (** slot without the MULTIPLE-option **) LOCATED := FALSE; SHADOW_STUB := LIST_HEAD; WHILE (SHADOW_STUB <> NIL) AND (NOT LOCATED) AND (NOT SP_IS_EMPTY_STR(SLOT^.NAME)) DO BEGIN STUB_REF := SHADOW_STUB^.STUB_POINTER; IF SP_EQ (STUB_REF^.NAME, SLOT^.NAME) THEN BEGIN LOCATED := TRUE; SLOT^.STUB_REF := STUB_REF; IF NOT SLOT^.OPTIONS.MULTIPLE THEN BEGIN IF STUB_REF^.NEXT_TWIN <> NIL THEN BEGIN STRING132.LENGTH := 0; STRING132.BODY := EMPTY_STRING_FIXED; FT_INIT_LINE (DUMMY_LINE); DIAG (ERR, 'ANALYSE (4.1) ', DUMMY_LINE, SLOT^.SRC_IMG, STRING132); SLOT^.OPTIONS.MULTIPLE := TRUE; END (*IF*); END (*IF*); END ELSE SHADOW_STUB := SHADOW_STUB^.NEXT; END (*WHILE*); (************* End of ANALYSE (4.1) ****************) SLOT := SLOT^.NEXT_SLOT; END (*WHILE*); STUB := STUB^.NEXT_STUB; END (*WHILE*); (********************* End of ANALYSE (4) ******************) (********************* ANALYSE (5) *************************) (** Check the resulting structure of CODE_STRUCT for **) (** circularity. If circularity is detected, break the **) (** responsible chain and generate a diagnostic. **) CHECK_CIRC (CODE_STRUCT, LIST_HEAD); (********************* End of ANALYSE (5) ******************) END (*IF*) (********************* End of ANALYSE body *********************) END (*PROCEDURE ANALYSE*); (*********************************************************************) (* Routine: GENMOD - MODule GENeration phase *) (* Purpose: Generation of modules out of CODE_STRUCT. *) (* Interface: CODE_STRUCT - Representation of the stub and slot *) (* structure. *) (* RUN_INFO: User's information for this run. *) (*********************************************************************) PROCEDURE GENMOD (CODE_STRUCT: CODE_STRUCT_; RUN_INFO: RUN_INFO_); VAR STB_PTR: STB_PTR_; CONTINUE: BOOLEAN; LOCATED: BOOLEAN; OUT_FILE: TEXT; NR_OPEN_SLOTS, NR_LINES, CORRECTION, INDENT: INTEGER; AUX_STRING_132 : STRING_FIXED_; AUX_STRING_9 : PACKED ARRAY[1..9] OF CHAR; EXTRACTED: BOOLEAN; CH1, CH2: CHAR; I: INTEGER; MODULE_NR: INTEGER; ERROR_CODE: ERROR_CODE_; X: INTEGER; TEMP_FILE_SPEC: STRING132_; REAL_FILE_SPEC: FILE_SPEC_; DUMMY_LINE: LINE_DES_; STRING132: STRING132_; (************************* GENMOD routines *************************) (*********************************************************************) (* Procedure: BUILDER - BUILDER of module. *) (* Purpose: Build one single module. *) (* Interface: STUB - Pointer to the starting point of the *) (* structure. *) (* OUT_FILE - File to accept the generated code. *) (* NR_OPEN_SLOTS - Number of open slots when ready. *) (* NR_LINES - Number of generated code lines. *) (* INDENT - Current indentation level. *) (* CORRECTION - Correction value for indentation. *) (*********************************************************************) PROCEDURE BUILDER (STUB: STB_PTR_; VAR OUT_FILE: TEXT; VAR NR_OPEN_SLOTS: INTEGER; VAR NR_LINES: INTEGER; VAR INDENT: INTEGER; VAR CORRECTION: INTEGER); VAR PREV_INDENT: INTEGER; TWIN_STUB: STB_PTR_; SLOT: SLT_PTR_; FIRST, LAST: INTEGER; INFO_LINE: LINE_DES_; SEG_LENGTH: INTEGER; STRING132: STRING132_; FILE_SPEC: FILE_SPEC_; K: INTEGER; DUMMY_FILE: VARYING [80] OF CHAR; DUMMY: VARYING [132] OF CHAR; BEGIN (********************* BUILDER (body) **************************) WITH STUB^ DO BEGIN CORRECTION := ST_GET_INDENT (STUB^.SRC_IMG); INDENT := INDENT-CORRECTION; IF STUB^.OPTIONS.LINENUMBER THEN BEGIN (************************* BUILDER (1) *********************) (** Use INDENT to write file specification and line number **) (** of the source file from which STUB^.SRC_IMG is extrac- **) (** ted to OUT_FILE. **) ST_GET_SEG_RANGE (STUB^.SRC_IMG, FIRST, LAST); ST_GET_FILE_SPEC (STUB^.SRC_IMG, FILE_SPEC); FT_INIT_LINE (INFO_LINE); INFO_LINE.INDENT := ST_GET_INDENT (STUB^.SRC_IMG); (* !!! *) DUMMY_FILE := ''; FOR K := 1 TO FILE_SPEC.LENGTH DO DUMMY_FILE := DUMMY_FILE + FILE_SPEC.BODY[K]; DUMMY := ''; WRITE (DUMMY, '(** Line: ', FIRST:1, ' File: ', DUMMY_FILE); (* ISO vreemd *) SEG_LENGTH := ST_SEG_WIDTH (STUB^.SRC_IMG); FOR K := LENGTH(DUMMY) TO (SEG_LENGTH - 4) DO DUMMY := DUMMY + ' '; DUMMY := DUMMY + '**)'; FOR K := 1 TO LENGTH(DUMMY) DO INFO_LINE.CHARS[K] := DUMMY[K]; (* !!! *) INFO_LINE.USED := LENGTH(DUMMY); (* !!! *) SP_EXTR_STR (STUB^.OPTIONS.INDENT, STRING132); IF (STRING132.BODY[1] = 'O') AND (STRING132.BODY[2] = 'N') THEN FT_WRLN (INFO_LINE, INDENT,1) ELSE FT_WRLN (INFO_LINE, 0, 1); (********************* End of BUILDER (1) ******************) NR_LINES := NR_LINES+1; END (*IF*); (************************* BUILDER (2) *************************) (** Use OPTIONS.COMMENT to decide if STUB^.SRC_IMG needs to be **) (** written to OUT_FILE. If so, then increase NR_LINES accor- **) (** dingly and use INDENT to position the segment. **) SP_EXTR_STR (STUB^.OPTIONS.COMMENT, STRING132); IF (STRING132.BODY[1] = 'O') AND (STRING132.BODY[2] = 'N') THEN BEGIN SP_EXTR_STR (STUB^.OPTIONS.INDENT, STRING132); IF (STRING132.BODY[1] = 'O') AND (STRING132.BODY[2] = 'N') THEN ST_WRITE_SEG (STUB^.SRC_IMG,INDENT,1) ELSE ST_WRITE_SEG (STUB^.SRC_IMG,0,1); NR_LINES := NR_LINES + ST_NUMBER_OF_LINES (STUB^.SRC_IMG); END (*IF*); (********************* End of BUILDER (2) **********************) SLOT := STUB^.SLOTS; WHILE SLOT <> NIL DO BEGIN (************************* BUILDER (3) *********************) (** SLOT inherits the options INDENT and COMMENT from STUB **) (** when they are not redefined. SLOT also inherits STUB^.- **) (** OPTIONS.LINENUMBER. **) IF SP_IS_EMPTY_STR (SLOT^.OPTIONS.INDENT) THEN SLOT^.OPTIONS.INDENT := STUB^.OPTIONS.INDENT; IF SP_IS_EMPTY_STR (SLOT^.OPTIONS.COMMENT) THEN SLOT^.OPTIONS.COMMENT := STUB^.OPTIONS.COMMENT; SLOT^.OPTIONS.LINENUMBER := STUB^.OPTIONS.LINENUMBER; (********************* End of BUILDER (3) ******************) IF SLOT^.STUB_REF = NIL THEN BEGIN (********************* BUILDER (4) *********************) (** SLOT has no reference to a stub. Write segments **) (** SLOT^.SRC_IMG and SLOT^.CODE to OUT_FILE using **) (** COMMENT and INDENT. Update NR_LINES accodingly. **) WITH SLOT^ DO BEGIN SP_EXTR_STR (STUB^.OPTIONS.COMMENT, STRING132); IF (STRING132.BODY[1] = 'O') AND (STRING132.BODY[2] = 'N') THEN BEGIN SP_EXTR_STR (SLOT^.OPTIONS.INDENT, STRING132); IF (STRING132.BODY[1] = 'O') AND (STRING132.BODY[2] = 'N') THEN ST_WRITE_SEG (SLOT^.SRC_IMG,INDENT,1) ELSE ST_WRITE_SEG (SLOT^.SRC_IMG, 0, 1); NR_LINES := NR_LINES + ST_NUMBER_OF_LINES (SLOT^.SRC_IMG); END (*IF*); SP_EXTR_STR (SLOT^.OPTIONS.INDENT, STRING132); IF (STRING132.BODY[1] = 'O') AND (STRING132.BODY[2] = 'N') THEN ST_WRITE_SEG (CODE,INDENT,1) ELSE ST_WRITE_SEG (CODE, 0, 1); NR_LINES := NR_LINES + ST_NUMBER_OF_LINES (SLOT^.CODE); END(*WITH*); (***************** End of BUILDER (4) ******************) IF (SLOT^.NEXT_SLOT <> NIL) AND (NOT SP_IS_EMPTY_STR(SLOT^.NAME)) AND (NOT SLOT^.OPTIONS.OPTIONAL) THEN BEGIN IF NR_OPEN_SLOTS = 0 THEN BEGIN WRITELN ('The following open slots are found:'); WRITELN; IF REPORT_OK THEN BEGIN WRITELN (REPORT_FILE, 'The following open slots are found:'); WRITELN (REPORT_FILE); END (*IF*); END (*IF*); (* Write slot to terminal and to output file. *) ST_WRITE_SEG (SLOT^.SRC_IMG, INDENT, 0); WRITELN; IF REPORT_OK THEN BEGIN ST_WRITE_SEG (SLOT^.SRC_IMG, INDENT, 3); WRITELN (REPORT_FILE); END (*IF*); NR_OPEN_SLOTS := NR_OPEN_SLOTS+1; END (*IF*); END ELSE BEGIN (********************* BUILDER (5) *********************) (** SLOT^.STUB_REF inherits the options INDENT and **) (** COMMENT from SLOT if they are not redefined by **) (** SLOT^.STUB_REF. SLOT^.STUB_REF also inherits **) (** LINENUMBER from SLOT. **) IF SP_IS_EMPTY_STR (SLOT^.STUB_REF^.OPTIONS.INDENT) THEN SLOT^.STUB_REF^.OPTIONS.INDENT := SLOT^.OPTIONS.INDENT; IF SP_IS_EMPTY_STR (SLOT^.STUB_REF^.OPTIONS.COMMENT) THEN SLOT^.STUB_REF^.OPTIONS.COMMENT := SLOT^.OPTIONS.COMMENT; SLOT^.STUB_REF^.OPTIONS.LINENUMBER := SLOT^.OPTIONS.LINENUMBER; (***************** End of BUILDER (5) ******************) PREV_INDENT := INDENT; INDENT := INDENT + ST_GET_INDENT (SLOT^.SRC_IMG); BUILDER (SLOT^.STUB_REF, OUT_FILE, NR_OPEN_SLOTS, NR_LINES, INDENT, CORRECTION); TWIN_STUB := SLOT^.STUB_REF^.NEXT_TWIN; WHILE TWIN_STUB <> NIL DO BEGIN (********************* BUILDER (6) *****************) (** TWIN_STUB inherits INDENT and COMMENT from **) (** SLOT when they are not redefined locally. In **) (** addition TWIN_STUB inherits LINENUMBER from **) (** SLOT. **) IF SP_IS_EMPTY_STR (TWIN_STUB^.OPTIONS.INDENT) THEN TWIN_STUB^.OPTIONS.INDENT := SLOT^.OPTIONS.INDENT; IF SP_IS_EMPTY_STR (TWIN_STUB^.OPTIONS.COMMENT) THEN TWIN_STUB^.OPTIONS.COMMENT := SLOT^.OPTIONS.COMMENT; TWIN_STUB^.OPTIONS.LINENUMBER := SLOT^.OPTIONS.LINENUMBER; (***************** End of BUILDER (6) **************) INDENT := ST_GET_INDENT (SLOT^.SRC_IMG); BUILDER (TWIN_STUB, OUT_FILE, NR_OPEN_SLOTS, NR_LINES, INDENT, CORRECTION); TWIN_STUB := TWIN_STUB^.NEXT_TWIN; END (*WHILE*); INDENT := PREV_INDENT; (********************* BUILDER (7) *********************) (** Write the segment SLOT^.CODE to OUT_FILE using the **) (** option SLOT^.INDENT. **) SP_EXTR_STR (SLOT^.OPTIONS.INDENT, STRING132); IF (STRING132.BODY[1] = 'O') AND (STRING132.BODY[2] = 'F') AND (STRING132.BODY[3] = 'F') THEN ST_WRITE_SEG (SLOT^.CODE, 0, 1) ELSE ST_WRITE_SEG (SLOT^.CODE,INDENT,1); (***************** End of BUILDER (7) ******************) NR_LINES := NR_LINES + ST_NUMBER_OF_LINES (SLOT^.CODE); END (*IF*); SLOT := SLOT^.NEXT_SLOT; END (*WHILE*); END (*WITH*); (********************* End of BUILDER (body) *******************) END (*PROCEDURE BUILDER*); (********************* End of GENMOD routines **********************) BEGIN (********************* GENMOD (body) ***************************) AUX_STRING_9 := 'EXTRACTED'; AUX_STRING_132 := EMPTY_STRING_FIXED; FOR I:= 1 TO 9 DO AUX_STRING_132[I] := AUX_STRING_9[I]; IF (RUN_INFO.EXTR_MODE <> AUX_STRING_132) THEN EXTRACTED := FALSE ELSE EXTRACTED := TRUE; STB_PTR := CODE_STRUCT.FIRST_STUB; WHILE STB_PTR <> NIL DO BEGIN LOCATED := FALSE; WHILE (STB_PTR <> NIL) AND (NOT LOCATED) DO BEGIN (************************* GENMOD (1) **********************) (** If STB_PTR refers to a main stub then use RUN_INFO to **) (** check if the module is desired by the user. Raise **) (** LOCATED if this happens to be the case. **) WITH STB_PTR^ DO BEGIN IF NOT SP_IS_EMPTY_STR (OPTIONS.FILE_NAME) THEN BEGIN (********************* GENMOD (1.1) ************************) (** Use RUN_INFO to check if OPTIONS.FILE_NAME indicates a **) (** module that is wanted by the user. Raise LOCATED if **) (** this is the case. Default the options COMMENT and **) (** INDENT it they have not been set explictely. **) WITH RUN_INFO DO BEGIN CH1 := 'O'; CH2 := 'N'; IF SP_IS_EMPTY_STR (OPTIONS.INDENT) THEN BEGIN SP_ADD_CHAR (CH1,OPTIONS.INDENT); SP_ADD_CHAR (CH2,OPTIONS.INDENT); END (*IF*); IF SP_IS_EMPTY_STR (OPTIONS.COMMENT) THEN BEGIN SP_ADD_CHAR (CH1,OPTIONS.COMMENT); SP_ADD_CHAR (CH2,OPTIONS.COMMENT); END (*IF*); SP_EXTR_STR (STB_PTR^.OPTIONS.FILE_NAME, TEMP_FILE_SPEC); LOCATED := FALSE; FOR X := 1 TO RUN_INFO.NR_MODULES DO BEGIN IF TEMP_FILE_SPEC.BODY= RUN_INFO.RSLT_MODULES[X].FILE_NAME.BODY THEN BEGIN LOCATED := TRUE; MODULE_NR := X; END (*IF*); END (*FOR*); (* Use the value of EXTRACTED to decide *) (* whether the module is wanted or not. *) IF EXTRACTED = FALSE THEN LOCATED := NOT LOCATED; END (*WITH*); (***************** End of GENMOD (1.1) *********************) END (*IF*); END (*WITH*); (********************* End of GENMOD (1) *******************) IF NOT LOCATED THEN STB_PTR := STB_PTR^.NEXT_STUB; END (*WHILE*); IF LOCATED THEN BEGIN CONTINUE := TRUE; (************************* GENMOD (2) **********************) (** Open OUT_FILE with a name specified by this main stub. **) (** Set CONTINUE to FALSE if there is a problem. STB_PTR^.- **) (** OPTIONS.FILE_NAME caused the problem and displayed as **) (** part of an error message. **) SP_EXTR_STR (STB_PTR^.OPTIONS.FILE_NAME, TEMP_FILE_SPEC); (* The type of TEMP_FILE_SPEC is not suitable for the File Table *) (* routine which opens files. It is converted to a REAL_FILE_SPEC. *) REAL_FILE_SPEC.BODY := EMPTY_STRING_FIXED; REAL_FILE_SPEC.LENGTH := 0; IF EXTRACTED THEN BEGIN FOR I:= 1 TO RUN_INFO.RSLT_MODULES[MODULE_NR].PATH.LENGTH DO REAL_FILE_SPEC.BODY[I] := RUN_INFO.RSLT_MODULES[MODULE_NR].PATH.BODY[I]; REAL_FILE_SPEC.LENGTH := RUN_INFO.RSLT_MODULES[MODULE_NR].PATH.LENGTH; END ELSE BEGIN FOR I:= 1 TO RUN_INFO.MODULE_DIRECTORY.LENGTH DO REAL_FILE_SPEC.BODY[I] := RUN_INFO.MODULE_DIRECTORY.BODY[I]; REAL_FILE_SPEC.LENGTH := RUN_INFO.MODULE_DIRECTORY.LENGTH; END; (*IF*) X := REAL_FILE_SPEC.LENGTH; I := 1; WHILE I <= TEMP_FILE_SPEC.LENGTH DO BEGIN X:=X+1; REAL_FILE_SPEC.BODY[X] := TEMP_FILE_SPEC.BODY[I]; I:=I+1; END (*WHILE*); REAL_FILE_SPEC.LENGTH := X; ERROR_CODE := FT_OUTOPEN (REAL_FILE_SPEC); IF ERROR_CODE > 0 THEN BEGIN CONTINUE := FALSE; (********************* GENMOD (2.1) ****************************) (** Use STB_PTR^.OPTIONS.FILE_NAME and the returned ERROR_CODE **) (** to generate an error message. **) FT_INIT_LINE (DUMMY_LINE); SP_EXTR_STR (STB_PTR^.OPTIONS.FILE_NAME, STRING132); DIAG (ERR, 'GENMOD (2.1) ', DUMMY_LINE, STB_PTR^.SRC_IMG, STRING132); (********************* End of GENMOD (2.1) *********************) END (*IF*); (********************* End of GENMOD (2) *******************) IF CONTINUE THEN BEGIN NR_OPEN_SLOTS := 0; NR_LINES := 0; (********************* GENMOD (3) **********************) (** Generate the module indicated by STB_PTR into **) (** OUT_FILE. NR_OPEN_SLOTS and NR_LINES are maintained **) (** as statistical data. **) WRITE ('Generating file: '); FOR X := 1 TO REAL_FILE_SPEC.LENGTH DO WRITE (REAL_FILE_SPEC.BODY[X]); WRITELN; IF REPORT_OK THEN BEGIN WRITE (REPORT_FILE, 'Generating file: '); FOR X := 1 TO REAL_FILE_SPEC.LENGTH DO WRITE (REPORT_FILE, REAL_FILE_SPEC.BODY[X]); WRITELN (REPORT_FILE); END (*IF*); INDENT := ST_GET_INDENT (STB_PTR^.SRC_IMG); CORRECTION := 0; NR_LINES := 0; NR_OPEN_SLOTS := 0; BUILDER (STB_PTR, OUT_FILE, NR_OPEN_SLOTS, NR_LINES, INDENT, CORRECTION); (******************* End of GENMOD (3) *****************) WRITELN ('Number of open slots in this module: ', NR_OPEN_SLOTS:1); WRITELN ('Number of generated lines: ',NR_LINES:1); WRITELN ('------------------------------------', '------------------------------------'); WRITELN; IF REPORT_OK THEN BEGIN WRITELN (REPORT_FILE, 'Number of open slots', ' in this module: ', NR_OPEN_SLOTS:1); WRITELN (REPORT_FILE, 'Number of generated lines: ' ,NR_LINES:1); WRITELN (REPORT_FILE, '------------------------------------', '------------------------------------'); WRITELN (REPORT_FILE); END (*IF*); (********************* GENMOD (4) **********************) (** Close OUT_FILE. Generate an error message in case **) (** of trouble. **) ERROR_CODE := FT_OUTCLOSE; IF ERROR_CODE <> 0 THEN BEGIN (************************* GENMOD (4.1) ************************) (** Use STB_PTR^.OPTIONS.FILE_NAME and STB_PTR^.SRC_IMG to **) (** generate a diagnostic message. **) FT_INIT_LINE (DUMMY_LINE); SP_EXTR_STR (STB_PTR^.OPTIONS.FILE_NAME, STRING132); DIAG (ERR, 'GENMOD (4.1) ', DUMMY_LINE, STB_PTR^.SRC_IMG, STRING132); (********************* End of GENMOD (4.1) *********************) END(*IF*); (***************** End of GENMOD (4) *******************) END (*IF*); STB_PTR := STB_PTR^.NEXT_STUB; END (*IF*); END (*WHILE*); (********************* End of GENMOD (body) ********************) END (*GENMOD*); BEGIN (******* CLIP_2 (body) *******) CONTINUE := TRUE; (***************************** CLIP_2 (1) **************************) (** Read the contents of CLIP.INI into RUN_INFO. Set CONTINUE to **) (** FALSE in case of trouble. **) EXT_FILE_SPEC.BODY := EMPTY_STRING_FIXED; AUX_STRING_8 := DFLT_INIFILE; FOR I := 1 TO 8 DO EXT_FILE_SPEC.BODY[I] := AUX_STRING_8[I]; EXT_FILE_SPEC.LENGTH := 8; EXT_FILE_PREP (INI_FILE, EXT_FILE_SPEC, INSP_MODE, DUMMY_FILE_OK, ERROR_CODE, DUMMY_ERROR_MSG); IF ERROR_CODE > 0 THEN BEGIN WRITELN ('The initializationfile could not be read succesfully.'); CONTINUE := FALSE; END ELSE BEGIN (* EWvA: 16/10/93 *) EXT_FILE_CLOSE (INI_FILE, DUMMY_ERROR_CODE); (* EWvA: 16/10/93 *) READ_INI_FILE (INI_FILE, RUN_INFO, EXT_FILE_SPEC, DUMMY_FILE_OK, DUMMY_ERROR_MSG, DUMMY_ERROR_CODE); END (* IF *); (* EWvA: 16/10/93 *) (************************* End of CLIP_2 (1) ***********************) IF CONTINUE THEN BEGIN (************************* CLIP_2 (2) **************************) (** Initialize CODE_STRUCT and the hidden variables of FT, ST, **) (** SP, SCN_LINE, SCN_OPTS and DIAG_TBL. **) FT_INIT; ST_INIT; SP_INIT; SCN_LINE_INIT; SCN_OPTS_INIT; DIAGNOST_INIT; CODE_STRUCT.LAST_STUB := NIL; CODE_STRUCT.FIRST_STUB := NIL; (********************* End of CLIP_2 (2) ***********************) (************************* CLIP_2 (3) **************************) (** Prepare a REPORT_FILE file from RUN_INFO.REPORT_FILE_SPEC **) (** and raise REPORT_OK if this succeeded. **) (* Modified by EWvA on 16/10/93 *) IF (RUN_INFO.REPORT_FILE_SPEC.BODY <> EMPTY_STRING_FIXED) AND (RUN_INFO.MESSAGE_DESTINATION[1] IN ['R','r','F','f','B','b']) (* End of modification dd. 16/10/93 *) THEN BEGIN EXT_FILE_PREP (REPORT_FILE, RUN_INFO.REPORT_FILE_SPEC, GEN_MODE, REPORT_OK, ERROR_CODE, ERROR_MSG); IF ERROR_CODE <> 0 THEN BEGIN WRITELN (OUTPUT, ERROR_MSG); WRITELN (OUTPUT, 'Continue without report file...'); WRITELN; REPORT_OK := FALSE; END ELSE REPORT_OK := TRUE; END ELSE (* EWvA: 16/10/93 *) REPORT_OK := FALSE; (* EWvA: 16/10/93 *) (***************** End of DIAGNOST_EXIT (2) ********************) START := CLOCK; STOP := START; (************************* CLIP_2 (4) **************************) (** Scan the source files as specified in RUN_INFO and build **) (** the structure of stubs and slots CODE_STRUCT. LPT_FILE_OK **) (** decides if info for the terminal is copied to REPORT_FILE. **) WRITELN; WRITELN ('============================ ', CLIP_VERSION, ' =========================='); WRITELN; WRITELN ('============================ Busy scanning ', '============================='); IF REPORT_OK THEN BEGIN WRITELN (REPORT_FILE); WRITELN (REPORT_FILE, '============================ ', CLIP_VERSION, ' =========================='); WRITELN (REPORT_FILE); WRITELN (REPORT_FILE, '============================ Busy scanning ', '============================='); END (*IF*); SCAN_FILES (CODE_STRUCT, RUN_INFO); WRITELN ('============================ End scanning ', '=============================='); WRITELN; IF REPORT_OK THEN BEGIN WRITELN (REPORT_FILE); WRITELN (REPORT_FILE, '============================ End scanning ', '=============================='); END (*IF*); (********************* End of CLIP_2 (4) **********************) IF CODE_STRUCT.FIRST_STUB <> NIL THEN BEGIN (************************* CLIP_2 (5) **********************) (** Analyse CODE_STRUCT. LPT_FILE_OK decides if info to the **) (** terminal is copied to REPORT_FILE also. **) WRITELN ('============================ Busy analysing ', '============================'); IF REPORT_OK THEN BEGIN WRITELN (REPORT_FILE); WRITELN (REPORT_FILE, '============================ Busy analysing ', '============================'); END (*IF*); ANALYSE (CODE_STRUCT); WRITELN ('============================ End analysing ', '============================='); WRITELN; IF REPORT_OK THEN BEGIN WRITELN (REPORT_FILE); WRITELN (REPORT_FILE, '============================ End analysing ', '============================='); END (*IF*); (********************* End of CLIP_2 (5) *******************) (************************* CLIP_2 (6) **********************) (** Generate the modules as specified in RUN_INFO out of **) (** CODE_STRUCT. LPT_FILE_OK decides if info for terminal **) (** is also copied to REPORT_FILE. **) WRITELN ('============================ Busy generating ', '==========================='); IF REPORT_OK THEN BEGIN WRITELN (REPORT_FILE); WRITELN (REPORT_FILE, '============================ Busy generating ', '==========================='); END (*IF*); GENMOD (CODE_STRUCT, RUN_INFO); WRITELN ('============================ End generating ', '============================'); WRITELN; IF REPORT_OK THEN BEGIN WRITELN (REPORT_FILE); WRITELN (REPORT_FILE, '============================ End generating ', '============================'); END (*IF*); (********************* End of CLIP_2 (6) *******************) STOP := CLOCK; END (*IF*); (*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +++++++++++ EWvA, jan6, 1993: Report file ++++++++++++ FT_INIT_LINE (DUMMY_LINE); ST_INIT_SEG (DUMMY_SEG); STRING132.LENGTH := 0; STRING132.BODY := EMPTY_STRING_FIXED; DIAG (WARN, 'CLIP_2 ', DUMMY_LINE, DUMMY_SEG, STRING132); ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*) (* Generate error messages to terminal and possibly report file *) DIAGNOST_EXIT; (* Delete the segment-table. *) ST_FINIT; (* Display a goodbye message. *) WRITELN ('Used (CPU) time :', (STOP-START)/1000:4:2, ' Sec.'); WRITELN ('See you next time !'); IF REPORT_OK THEN BEGIN WRITELN (REPORT_FILE, 'Used (CPU) time :', (STOP-START)/1000:4:2, ' Sec.'); WRITELN (REPORT_FILE, 'See you next time !'); EXT_FILE_CLOSE (REPORT_FILE, DUMMY_ERROR); END (*FI*); END (*IF*); (********************* End of CLIP_2 (body) ********************) END (*CLIP_2*). (******************* End of module clip_unix.pas *******************)